- optimize away dispatch\r
- getenv/setenv: if literal arg, compile as a load/store\r
- assembler opcodes dispatch on operand types\r
-- save code in image\r
\r
+ oop:\r
\r
USE: unparser
USE: kernel-internals
-: cli-args ( -- args ) 10 getenv ;
+: init-smart-terminal
+ "smart-terminal" get [
+ stdio smart-term-hook get change
+ ] when ;
: warm-boot ( -- )
#! A fully bootstrapped image has this as the boot
#! quotation.
boot
-
init-error-handler
init-random
- init-assembler
-
- ! Some flags are *on* by default, unless user specifies
- ! -no-<flag> CLI switch
- t "user-init" set
- t "interactive" set
- t "compile" set
- t "smart-terminal" set
-
- ! The first CLI arg is the image name.
- cli-args uncons parse-command-line "image" set
+ default-cli-args
+ parse-command-line
os "win32" = "compile" get and [
"kernel32" "kernel32.dll" "stdcall" add-library
"libc" "msvcrt.dll" "cdecl" add-library
] when
- "compile" get [ compile-all ] when
-
- "smart-terminal" get [
- stdio smart-term-hook get change
- ] when
-
+ init-smart-terminal
run-user-init ;
-: auto-inline-count 5 ;
+: auto-inline-count 3 ;
[
warm-boot
garbage-collection
init-error-handler
-0 [ drop succ ] each-word unparse write " words" print
-
-"Counting word usages..." print
-tally-usages
+! "Counting word usages..." print
+! tally-usages
!
! "Automatically inlining words called " write
! auto-inline-count unparse write
! " or less times..." print
! auto-inline-count auto-inline
-"Inferring stack effects..." print
-0 [ unit try-infer [ succ ] when ] each-word
-unparse write " words have a stack effect" print
+default-cli-args
+parse-command-line
+
+"Compiling system..." print
+"compile" get [ compile-all ] when
+
+0 [ compiled? [ succ ] when ] each-word
+unparse write " words compiled" print
+
+0 [ drop succ ] each-word
+unparse write " words total" print
"Bootstrapping is complete." print
"Now, you can run ./f factor.image" print
USE: streams
USE: strings
USE: words
+USE: kernel-internals
! This file is run as the last stage of boot.factor; it relies
! on all other words already being defined.
: run-files ( args -- )
[ [ run-file ] when* ] each ;
-: parse-command-line ( args -- )
+: default-cli-args
+ #! Some flags are *on* by default, unless user specifies
+ #! -no-<flag> CLI switch
+ t "user-init" set
+ t "interactive" set
+ t "smart-terminal" set
+ t "verbose-compile" set
+ t "compile" set ;
+
+: cli-args ( -- args ) 10 getenv ;
+
+: parse-command-line ( -- )
#! Parse command line arguments.
- parse-switches run-files ;
+ #! The first CLI arg is the image name.
+ cli-args unswons "image" set parse-switches run-files ;
USE: alien
USE: math
USE: kernel
+USE: hashtables
+USE: namespaces
-: cell 4 ; inline
-: literal-table 1024 cell * ; inline
+SYMBOL: interned-literals
-: init-assembler ( -- )
- compiled-offset literal-table + set-compiled-offset ;
+: cell 4 ; inline
+: compiled-header HEX: 01c3babe ; inline
: set-compiled-byte ( n addr -- )
<alien> 0 set-alien-1 ; inline
<alien> 0 set-alien-cell ; inline
: compile-aligned ( n -- )
- compiled-offset swap align set-compiled-offset ; inline
+ compiled-offset cell 2 * align set-compiled-offset ; inline
: intern-literal ( obj -- lit# )
- address
- literal-top set-compiled-cell
- literal-top dup cell + set-literal-top ;
+ dup interned-literals get hash dup [
+ nip
+ ] [
+ drop [
+ address
+ literal-top set-compiled-cell
+ literal-top dup cell + set-literal-top
+ dup
+ ] keep interned-literals get set-hash
+ ] ifte ;
: compile-byte ( n -- )
compiled-offset set-compiled-byte
: compile-cell ( n -- )
compiled-offset set-compiled-cell
compiled-offset cell + set-compiled-offset ; inline
+
+: begin-assembly ( -- code-len-fixup reloc-len-fixup )
+ compiled-header compile-cell
+ compiled-offset 0 compile-cell
+ compiled-offset 0 compile-cell ;
+
+global [ <namespace> interned-literals set ] bind
"Unsupported CPU; compiler disabled" throw
] unless ;
-: compiling ( word -- definition )
+: compiling ( word -- word parameter )
check-architecture
"verbose-compile" get [
"Compiling " write dup . flush
] when
- cell compile-aligned dup save-xt word-parameter ;
+ dup word-parameter ;
: (compile) ( word -- )
#! Should be called inside the with-compiler scope.
#! Compile the most recently defined word.
"compile" get [ word compile ] when ; parsing
-: cannot-compile ( word -- )
+: cannot-compile ( word error -- )
"verbose-compile" get [
- "Cannot compile " write .
+ "Cannot compile " write swap .
+ default-error-handler
] [
- drop
+ 2drop
] ifte ;
: try-compile ( word -- )
- [ compile ] [ [ cannot-compile ] when ] catch ;
+ [ compile ] [ [ cannot-compile ] when* ] catch ;
: compile-all ( -- )
#! Compile all words.
USE: namespaces
USE: words
USE: lists
+USE: math
: DS ( -- address ) "ds" dlsym-self ;
+: absolute-ds ( -- )
+ #! Add an entry to the relocation table for the 32-bit
+ #! immediate just compiled.
+ "ds" f rel-dlsym-self ;
+
: POP-DS ( -- )
#! Pop datastack to EAX.
- DS ECX [I]>R
+ DS ECX [I]>R absolute-ds
ECX EAX [R]>R
4 ECX R-I
- ECX DS R>[I] ;
+ ECX DS R>[I] absolute-ds ;
#push-immediate [
- DS ECX [I]>R
+ DS ECX [I]>R absolute-ds
4 ECX R+I
address ECX I>[R]
- ECX DS R>[I]
+ ECX DS R>[I] absolute-ds
] "generator" set-word-property
#push-indirect [
- DS ECX [I]>R
+ DS ECX [I]>R absolute-ds
4 ECX R+I
- intern-literal EAX [I]>R
+ intern-literal EAX [I]>R rel-address
EAX ECX R>[R]
- ECX DS R>[I]
+ ECX DS R>[I] absolute-ds
] "generator" set-word-property
#replace-immediate [
- DS ECX [I]>R
+ DS ECX [I]>R absolute-ds
address ECX I>[R]
- ECX DS R>[I]
+ ECX DS R>[I] absolute-ds
] "generator" set-word-property
#replace-indirect [
- DS ECX [I]>R
- intern-literal EAX [I]>R
+ DS ECX [I]>R absolute-ds
+ intern-literal EAX [I]>R rel-address
EAX ECX R>[R]
- ECX DS R>[I]
+ ECX DS R>[I] absolute-ds
] "generator" set-word-property
#call [
- dup postpone-word
+ dup dup postpone-word
CALL compiled-offset defer-xt
+ t rel-word
] "generator" set-word-property
#jump [
- dup postpone-word
+ dup dup postpone-word
JUMP compiled-offset defer-xt
+ t rel-word
] "generator" set-word-property
#call-label [
] "generator" set-word-property
#return-to [
- PUSH-I/PARTIAL 0 defer-xt
+ PUSH-I/PARTIAL 0 defer-xt rel-address
] "generator" set-word-property
#return [ drop RET ] "generator" set-word-property
#! The jump table must immediately follow this macro.
drop
POP-DS
- 1 EAX R>>I ( -- fixup )
- EAX+/PARTIAL
+ 1 EAX R>>I
+ EAX+/PARTIAL ( -- fixup ) rel-address
EAX JUMP-[R]
- cell compile-aligned
+ compile-aligned
compiled-offset swap set-compiled-cell ( fixup -- )
] "generator" set-word-property
#target [
#! Jump table entries are absolute addresses.
- compiled-offset 0 compile-cell 0 defer-xt
+ compiled-offset 0 compile-cell 0 defer-xt rel-address
] "generator" set-word-property
#c-call [ CALL JUMP-FIXUP ] "generator" set-word-property
[ #r> r> ]
] [
uncons
- [ car CALL compiled-offset defer-xt drop ] cons
+ [
+ car dup CALL compiled-offset defer-xt t rel-word drop
+ ] cons
"generator" set-word-property
] each
USE: namespaces
USE: strings
USE: words
+USE: vectors
+
+! To support saving compiled code to disk, generator words
+! append relocation instructions to this vector.
+SYMBOL: relocation-table
+
+: rel, ( n -- ) relocation-table get vector-push ;
+
+: relocating compiled-offset cell - rel, ;
+
+: rel-primitive ( word rel/abs -- )
+ #! If flag is true; relative.
+ 0 1 ? rel, relocating word-primitive rel, ;
+
+: rel-word ( word rel/abs -- )
+ #! If flag is true; relative.
+ over primitive? [ rel-primitive ] [ 2drop ] ifte ;
+
+: rel-dlsym-self ( name rel/abs -- )
+ #! If flag is true; relative.
+ 2 3 ? rel, relocating intern-literal rel, ;
+
+: rel-address ( -- )
+ #! Relocate address just compiled.
+ 4 rel, relocating 0 rel, ;
: generate-node ( [ op | params ] -- )
#! Generate machine code for a node.
"No generator" throw
] ifte ;
-: generate ( linear -- )
+: generate-code ( word linear -- length )
+ compiled-offset >r
+ compile-aligned
+ swap save-xt
+ [ generate-node ] each
+ compile-aligned
+ compiled-offset r> - ;
+
+: generate-reloc ( -- length )
+ relocation-table get
+ dup [ compile-cell ] vector-each
+ vector-length cell * ;
+
+: generate ( word linear -- )
#! Compile a word definition from linear IR.
- [ generate-node ] each ;
+ 100 <vector> relocation-table set
+ begin-assembly swap >r >r
+ generate-code
+ generate-reloc
+ r> set-compiled-cell
+ r> set-compiled-cell ;
#label [ save-xt ] "generator" set-word-property
[ 1 [ ] 2keep ] unit-test-fails
[ 3 1 2 ] [ 1 2 [ 2drop 3 ] 2keep ] unit-test
-[ cond ] unit-test-fails
-[ [ [ 1 = ] [ ] ] cond ] unit-test-fails
-
-[ ] [ 3 [ ] cond ] unit-test
-[ t ] [ 4 [ [ 1 = ] [ ] [ 4 = ] [ drop t ] [ 2 = ] [ ] ] cond ] unit-test
-
[ 0 ] [ f [ sq ] [ 0 ] ifte* ] unit-test
[ 4 ] [ 2 [ sq ] [ 0 ] ifte* ] unit-test
[ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
[ [ [ object ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
[ [ [ vector ] [ vector ] ] ] [ [ vector-clone ] infer ] unit-test
-[ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test
-[ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test
+! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test
+! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test
F_ARRAY* allot_array(CELL type, CELL capacity)
{
F_ARRAY* array;
- if(capacity < 0)
- general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
array = allot_object(type,sizeof(F_ARRAY) + capacity * CELLS);
array->capacity = capacity;
return array;
{
int i = 0;
for(i = 0; i < array->capacity; i++)
- fixup((void*)AREF(array,i));
+ data_fixup((void*)AREF(array,i));
}
void collect_array(F_ARRAY* array)
#include "factor.h"
-void init_compiler(void)
-{
- init_zone(&compiling,COMPILE_ZONE_SIZE);
- literal_top = compiling.base;
-}
-
void primitive_compiled_offset(void)
{
box_integer(compiling.here);
void primitive_set_literal_top(void)
{
CELL offset = unbox_integer();
+ if(offset >= literal_max)
+ critical_error("Too many compiled literals",offset);
literal_top = offset;
}
+/* The compiled code heap is structures into blocks. */
+typedef struct
+{
+ CELL header;
+ CELL code_length;
+ CELL reloc_length;
+} F_COMPILED;
+
+#define COMPILED_HEADER 0x01c3babe
+
ZONE compiling;
+
+#define LITERAL_TABLE 4096
+
CELL literal_top;
+CELL literal_max;
-void init_compiler(void);
void primitive_compiled_offset(void);
void primitive_set_compiled_offset(void);
void primitive_literal_top(void);
init_io();
init_signals();
- init_compiler();
init_errors();
- gc_time = 0;
#ifdef FACTOR_X86
userenv[CPU_ENV] = tag_object(from_c_string("x86"));
#include "arithmetic.h"
#include "string.h"
#include "misc.h"
-#include "relocate.h"
#include "sbuf.h"
#include "port.h"
#include "io.h"
#include "vector.h"
#include "stack.h"
#include "compiler.h"
+#include "relocate.h"
#include "ffi.h"
#endif /* __FACTOR_H__ */
void primitive_local_alien(void)
{
- CELL length = unbox_integer();
+ F_FIXNUM length = unbox_integer();
ALIEN* alien;
F_STRING* local;
+ if(length < 0)
+ general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(length));
maybe_garbage_collection();
alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
local = string(length / CHARS,'\0');
{
FILE* file;
HEADER h;
- CELL size;
-
+ HEADER_2 ext_h;
+
printf("Loading %s...",filename);
file = fopen(filename,"rb");
if(file == NULL)
fatal_error("Cannot open image for reading",errno);
- /* read it in native byte order */
- fread(&h,sizeof(HEADER)/sizeof(CELL),sizeof(CELL),file);
-
- if(h.magic != IMAGE_MAGIC)
- fatal_error("Bad magic number",h.magic);
- if(h.version != IMAGE_VERSION)
- fatal_error("Bad version number",h.version);
-
- allot(h.size);
-
- size = h.size / CELLS;
-
- if(size != fread((void*)active.base,sizeof(CELL),size,file))
- fatal_error("Wrong image length",h.size);
+ /* read header */
+ {
+ /* read it in native byte order */
+ fread(&h,sizeof(HEADER)/sizeof(CELL),sizeof(CELL),file);
+
+ if(h.magic != IMAGE_MAGIC)
+ fatal_error("Bad magic number",h.magic);
+
+ if(h.version == IMAGE_VERSION)
+ fread(&ext_h,sizeof(HEADER_2)/sizeof(CELL),sizeof(CELL),file);
+ else if(h.version == IMAGE_VERSION_0)
+ {
+ ext_h.size = LITERAL_TABLE;
+ ext_h.literal_top = 0;
+ ext_h.literal_max = LITERAL_TABLE;
+ ext_h.relocation_base = compiling.base;
+ }
+ else
+ fatal_error("Bad version number",h.version);
+ }
+
+ /* read data heap */
+ {
+ CELL size = h.size / CELLS;
+ allot(h.size);
+
+ if(size != fread((void*)active.base,sizeof(CELL),size,file))
+ fatal_error("Wrong data heap length",h.size);
+
+ active.here = active.base + h.size;
+ data_relocation_base = h.relocation_base;
+ }
+
+ /* read code heap */
+ {
+ CELL size = ext_h.size;
+ if(size + compiling.base >= compiling.limit)
+ fatal_error("Code heap too large",ext_h.size);
+
+ if(h.version == IMAGE_VERSION
+ && size != fread((void*)compiling.base,1,size,file))
+ fatal_error("Wrong code heap length",ext_h.size);
+
+ compiling.here = compiling.base + ext_h.size;
+ literal_top = compiling.base + ext_h.literal_top;
+ literal_max = compiling.base + ext_h.literal_max;
+ compiling.here = compiling.base + ext_h.size;
+ code_relocation_base = ext_h.relocation_base;
+ }
- active.here = active.base + h.size;
fclose(file);
printf(" relocating...");
userenv[GLOBAL_ENV] = h.global;
userenv[BOOT_ENV] = h.boot;
- relocate(h.relocation_base);
+ relocate_data();
+ relocate_code();
printf(" done\n");
fflush(stdout);
{
FILE* file;
HEADER h;
+ HEADER_2 ext_h;
fprintf(stderr,"Saving %s...\n",filename);
-
+
file = fopen(filename,"wb");
if(file == NULL)
fatal_error("Cannot open image for writing",errno);
h.version = IMAGE_VERSION;
h.relocation_base = active.base;
h.boot = userenv[BOOT_ENV];
- h.size = (active.here - active.base);
+ h.size = active.here - active.base;
h.global = userenv[GLOBAL_ENV];
-
fwrite(&h,sizeof(HEADER),1,file);
+
+ ext_h.size = compiling.here - compiling.base;
+ ext_h.literal_top = literal_top - compiling.base;
+ ext_h.literal_max = literal_max - compiling.base;
+ ext_h.relocation_base = compiling.base;
+ fwrite(&ext_h,sizeof(HEADER_2),1,file);
+
fwrite((void*)active.base,h.size,1,file);
+ fwrite((void*)compiling.base,ext_h.size,1,file);
fclose(file);
#define IMAGE_MAGIC 0x0f0e0d0c
-#define IMAGE_VERSION 0
+#define IMAGE_VERSION_0 0
+#define IMAGE_VERSION 1
typedef struct {
CELL magic;
CELL size;
} HEADER;
+/* If version is IMAGE_VERSION_1 */
+typedef struct EXT_HEADER {
+ /* size of code heap */
+ CELL size;
+ /* code relocation base */
+ CELL relocation_base;
+ /* end of literal table */
+ CELL literal_top;
+ /* maximum value of literal_top */
+ CELL literal_max;
+} HEADER_2;
+
void load_image(char* file);
bool save_image(char* file);
void primitive_save_image(void);
{
init_zone(&active,size);
init_zone(&prior,size);
+ init_zone(&compiling,size);
allot_profiling = false;
gc_in_progress = false;
+ gc_time = 0;
}
void allot_profile_step(CELL a)
void fixup_port(F_PORT* port)
{
port->fd = (F_FIXNUM)INVALID_HANDLE_VALUE;
- fixup(&port->buffer);
- fixup(&port->line);
- fixup(&port->client_host);
- fixup(&port->client_port);
- fixup(&port->io_error);
+ data_fixup(&port->buffer);
+ data_fixup(&port->line);
+ data_fixup(&port->client_host);
+ data_fixup(&port->client_port);
+ data_fixup(&port->io_error);
}
void collect_port(F_PORT* port)
#include "factor.h"
-void fixup(CELL* cell)
-{
- if(TAG(*cell) != FIXNUM_TYPE && *cell != F)
- *cell += (active.base - relocation_base);
-}
-
-void relocate_object()
+void relocate_object(CELL relocating)
{
switch(untag_header(get(relocating)))
{
fixup_alien((ALIEN*)relocating);
break;
}
-
}
-void relocate_next()
+INLINE CELL relocate_data_next(CELL relocating)
{
CELL size = CELLS;
{
case HEADER_TYPE:
size = untagged_object_size(relocating);
- relocate_object();
+ relocate_object(relocating);
break;
case OBJECT_TYPE:
if(get(relocating) == F)
break;
/* fall thru */
default:
- fixup((CELL*)relocating);
+ data_fixup((CELL*)relocating);
break;
}
- relocating += size;
+
+ return relocating + size;
}
-void init_object(CELL* handle, CELL type)
+INLINE CELL init_object(CELL relocating, CELL* handle, CELL type)
{
if(untag_header(get(relocating)) != type)
fatal_error("init_object() failed",get(relocating));
*handle = tag_object((CELL*)relocating);
- relocate_next();
+ return relocate_data_next(relocating);
}
-void relocate(CELL r)
+void relocate_data()
{
- relocation_base = r;
-
- fixup(&userenv[BOOT_ENV]);
- fixup(&userenv[GLOBAL_ENV]);
+ CELL relocating = active.base;
- relocating = active.base;
+ data_fixup(&userenv[BOOT_ENV]);
+ data_fixup(&userenv[GLOBAL_ENV]);
/* The first object in the image must always T */
- init_object(&T,T_TYPE);
+ relocating = init_object(relocating,&T,T_TYPE);
/* The next three must be bignum 0, 1, -1 */
- init_object(&bignum_zero,BIGNUM_TYPE);
- init_object(&bignum_pos_one,BIGNUM_TYPE);
- init_object(&bignum_neg_one,BIGNUM_TYPE);
-
+ relocating = init_object(relocating,&bignum_zero,BIGNUM_TYPE);
+ relocating = init_object(relocating,&bignum_pos_one,BIGNUM_TYPE);
+ relocating = init_object(relocating,&bignum_neg_one,BIGNUM_TYPE);
+
for(;;)
{
if(relocating >= active.here)
break;
- relocate_next();
+ relocating = relocate_data_next(relocating);
+ }
+
+ relocating = compiling.base;
+
+ for(;;)
+ {
+ if(relocating >= literal_top)
+ break;
+
+ relocating = relocate_data_next(relocating);
+ }
+}
+
+void relocate_primitive(F_REL* rel, bool relative)
+{
+ /* this is intended for x86, so the address is relative to after
+ the insn, ie offset + CELLS. */
+ put(rel->offset,primitive_to_xt(rel->argument)
+ - (relative ? rel->offset + CELLS : 0));
+}
+
+void relocate_dlsym(F_REL* rel, bool relative)
+{
+ F_STRING* str = untag_string(get(rel->argument));
+ char* c_str = to_c_string(str);
+ put(rel->offset,(CELL)dlsym(NULL,c_str)
+ - (relative ? rel->offset + CELLS : 0));
+}
+
+INLINE CELL relocate_code_next(CELL relocating)
+{
+ F_COMPILED* compiled = (F_COMPILED*)relocating;
+
+ F_REL* rel = (F_REL*)(
+ relocating + sizeof(F_COMPILED)
+ + compiled->code_length);
+
+ F_REL* rel_end = (F_REL*)(
+ relocating + sizeof(F_COMPILED)
+ + compiled->code_length
+ + compiled->reloc_length);
+
+ if(compiled->header != COMPILED_HEADER)
+ fatal_error("Wrong compiled header",relocating);
+
+ while(rel < rel_end)
+ {
+ /* to_c_string can fill up the heap */
+ maybe_garbage_collection();
+
+ code_fixup(&rel->offset);
+
+ switch(rel->type)
+ {
+ case F_RELATIVE_PRIMITIVE:
+ relocate_primitive(rel,true);
+ break;
+ case F_ABSOLUTE_PRIMITIVE:
+ relocate_primitive(rel,false);
+ break;
+ case F_RELATIVE_DLSYM_SELF:
+ code_fixup(&rel->argument);
+ relocate_dlsym(rel,true);
+ break;
+ case F_ABSOLUTE_DLSYM_SELF:
+ code_fixup(&rel->argument);
+ relocate_dlsym(rel,false);
+ break;
+ case F_ABSOLUTE:
+ code_fixup((CELL*)rel->offset);
+ break;
+ default:
+ fatal_error("Unsupported rel",rel->type);
+ break;
+ }
+
+ rel++;
+ }
+
+ return (CELL)rel_end;
+}
+
+void relocate_code()
+{
+ /* start relocating from the end of the space reserved for literals */
+ CELL relocating = literal_max;
+
+ for(;;)
+ {
+ /* fprintf(stderr,"relocation %d %d\n",relocating,compiling.here); */
+ if(relocating >= compiling.here)
+ break;
+
+ relocating = relocate_code_next(relocating);
}
}
-/* relocation base of currently loaded image */
-CELL relocation_base;
+/* relocation base of currently loaded image's data heap */
+CELL data_relocation_base;
-/* used as a temporary variable while relocating */
-CELL relocating;
+INLINE void data_fixup(CELL* cell)
+{
+ if(TAG(*cell) != FIXNUM_TYPE && *cell != F)
+ *cell += (active.base - data_relocation_base);
+}
-void fixup(CELL* cell);
-void relocate_object();
-void relocate_next(void);
-void relocate(CELL r);
+typedef enum {
+ /* arg is a primitive number */
+ F_RELATIVE_PRIMITIVE,
+ F_ABSOLUTE_PRIMITIVE,
+ /* arg is an pointer in the literal table holding a tagged string */
+ F_RELATIVE_DLSYM_SELF,
+ F_ABSOLUTE_DLSYM_SELF,
+ /* relocate an address to start of code heap */
+ F_ABSOLUTE
+} F_RELTYPE;
+
+/* code relocation consists of a table of entries for each fixup */
+typedef struct {
+ F_RELTYPE type;
+ CELL offset;
+ CELL argument;
+} F_REL;
+
+CELL code_relocation_base;
+
+INLINE void code_fixup(CELL* cell)
+{
+ *cell += (compiling.base - code_relocation_base);
+}
+
+void relocate_data();
+void relocate_code();
F_SBUF* sbuf(F_FIXNUM capacity)
{
- F_SBUF* sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
+ F_SBUF* sbuf;
+ if(capacity < 0)
+ general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
+ sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
sbuf->top = 0;
sbuf->string = tag_object(string(capacity,'\0'));
return sbuf;
void fixup_sbuf(F_SBUF* sbuf)
{
- fixup(&sbuf->string);
+ data_fixup(&sbuf->string);
}
void collect_sbuf(F_SBUF* sbuf)
#include "factor.h"
/* untagged */
-F_STRING* allot_string(F_FIXNUM capacity)
+F_STRING* allot_string(CELL capacity)
{
- F_STRING* string;
- if(capacity < 0)
- general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
- string = allot_object(STRING_TYPE,
+ F_STRING* string = allot_object(STRING_TYPE,
sizeof(F_STRING) + capacity * CHARS);
string->capacity = capacity;
return string;
/* call this after constructing a string */
/* uses same algorithm as java.lang.String for compatibility with
images generated from Java Factor. */
-F_FIXNUM hash_string(F_STRING* str, F_FIXNUM len)
+F_FIXNUM hash_string(F_STRING* str, CELL len)
{
F_FIXNUM hash = 0;
CELL i;
}
/* untagged */
-F_STRING* string(F_FIXNUM capacity, CELL fill)
+F_STRING* string(CELL capacity, CELL fill)
{
CELL i;
return (F_STRING*)UNTAG(tagged);
}
-F_STRING* allot_string(F_FIXNUM capacity);
-F_STRING* string(F_FIXNUM capacity, CELL fill);
-F_FIXNUM hash_string(F_STRING* str, F_FIXNUM len);
+F_STRING* allot_string(CELL capacity);
+F_STRING* string(CELL capacity, CELL fill);
+F_FIXNUM hash_string(F_STRING* str, CELL len);
void rehash_string(F_STRING* str);
F_STRING* grow_string(F_STRING* string, F_FIXNUM capacity, uint16_t fill);
BYTE* to_c_string(F_STRING* s);
size = sizeof(ALIEN);
break;
default:
- critical_error("Cannot determine size",relocating);
+ critical_error("Cannot determine size",pointer);
size = -1;/* can't happen */
break;
}
F_VECTOR* vector(F_FIXNUM capacity)
{
- F_VECTOR* vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
+ F_VECTOR* vector;
+ if(capacity < 0)
+ general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
+ vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
vector->top = 0;
vector->array = tag_object(array(capacity,F));
return vector;
void fixup_vector(F_VECTOR* vector)
{
- fixup(&vector->array);
+ data_fixup(&vector->array);
}
void collect_vector(F_VECTOR* vector)
void fixup_word(F_WORD* word)
{
- update_xt(word);
- fixup(&word->parameter);
- fixup(&word->plist);
+ if(word->xt >= code_relocation_base
+ && word->xt < code_relocation_base
+ - compiling.base + compiling.limit)
+ code_fixup(&word->xt);
+ else
+ update_xt(word);
+
+ data_fixup(&word->parameter);
+ data_fixup(&word->plist);
}
void collect_word(F_WORD* word)
projects / factor.git / commitdiff