diff --git a/Makefile b/Makefile index 0b3a254adc..1ef2485b08 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,16 @@ CC = gcc + +# On PowerPC G5: +# CFLAGS = -mcpu=970 -mtune=970 -mpowerpc64 -ffast-math -O3 +# On Pentium 4: +# CFLAGS = -march=pentium4 -ffast-math -O3 +# Add -fomit-frame-pointer if you don't care about debugging CFLAGS = -Os -g -Wall + +# On Solaris: +# LIBS = -lsocket -lnsl -lm LIBS = -lm + STRIP = strip OBJS = native/arithmetic.o native/array.o native/bignum.o \ @@ -14,10 +24,10 @@ OBJS = native/arithmetic.o native/array.o native/bignum.o \ native/run.o \ native/sbuf.o native/socket.o native/stack.o \ native/string.o native/types.o native/vector.o \ - native/write.o native/word.o + native/write.o native/word.o native/compiler.o f: $(OBJS) - $(CC) $(LIBS) -o $@ $(OBJS) + $(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS) # $(STRIP) $@ clean: diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 6212d76b46..9083cd685f 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -8,7 +8,7 @@ - jedit ==> jedit-word, jedit takes a file name - introduce ifte* and ?str-head/?str-tail where appropriate - namespace clone drops static var bindings -- solaris: -lsocket -lnsl + The binary register ordering, from 0 to 7, is EAX, ECX, EDX, EBX, ESP, EBP, ESI, EDI. + bignums: diff --git a/doc/devel-guide.tex b/doc/devel-guide.tex index efa0b74734..9b31957c3c 100644 --- a/doc/devel-guide.tex +++ b/doc/devel-guide.tex @@ -2351,17 +2351,32 @@ Notice that until now, all the code except a handful of examples has only used t Variables are typically used for longer-term storage of data, and for temporary storage of objects that are being constructed, where using the stack would be ackward. Another use for variables is compound data structures, realized as nested namespaces of variables. This concept should be instantly familiar to anybody who's used an object-oriented programming language. -The words \texttt{get ( name -{}- value )} and \texttt{set ( value name -{}- )} retreive and store variable values, respectively. For example: +The words \texttt{get ( name -{}- value )} and \texttt{set ( value name -{}- )} retreive and store variable values, respectively. Variable names are strings, and they do not have to be declared before use. For example: -blah blah +\begin{alltt} +5 "x" set +"x" get . +\emph{5} +\end{alltt} \subsection{Namespaces} -describe bind and extend combinators +Only having one list of variable name/value bindings would make the language terribly inflexible. Instead, a variable has any number of potential values, one per namespace. There is a notion of a ``current namespace''; the \texttt{set} word always stores variables in the current namespace. On the other hand, \texttt{get} traverses up the stack of namespace bindings until it finds a variable with the specified name. -namespaces are hashtables +\texttt{bind ( namespace quot -{}- )} executes a quotation in the dynamic scope of a namespace. For example, the following sets the value of \texttt{x} to 5 in the global namespace, regardless of the current namespace at the time the word was called. -values, vars, vars-values +\begin{alltt} +: global-example ( -- ) + global {[} 5 "x" set {]} bind ; +\end{alltt} + +\texttt{ ( -{}- namespace )} creates a new namespace object. Actually, a namespace is just a hashtable, with a default capacity. + +\texttt{with-scope ( quot -{}- )} combines \texttt{} with \texttt{bind} by executing a quotation in a new namespace. + +get example + +describe \subsection{The name stack} diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index e9ded25636..390976ecbb 100644 --- a/library/cross-compiler.factor +++ b/library/cross-compiler.factor @@ -41,6 +41,11 @@ USE: vectors USE: vectors USE: words +IN: compiler +DEFER: compile-byte +DEFER: compile-cell +DEFER: compile-offset + IN: kernel DEFER: getenv DEFER: setenv @@ -106,6 +111,8 @@ DEFER: (random-int) IN: words DEFER: DEFER: word-hashcode +DEFER: word-xt +DEFER: set-word-xt DEFER: word-primitive DEFER: set-word-primitive DEFER: word-parameter @@ -205,6 +212,8 @@ IN: cross-compiler word? word-hashcode + word-xt + set-word-xt word-primitive set-word-primitive word-parameter @@ -268,6 +277,9 @@ IN: cross-compiler dump cwd cd + compile-byte + compile-cell + compile-offset ] [ swap succ tuck primitive, ] each drop ; diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor index b38d0a1289..07448c7ff7 100644 --- a/library/platform/native/boot-stage2.factor +++ b/library/platform/native/boot-stage2.factor @@ -109,6 +109,7 @@ USE: stdio "/library/telnetd.factor" "/library/inferior.factor" "/library/platform/native/profiler.factor" + "/library/platform/native/compiler.factor" "/library/image.factor" "/library/cross-compiler.factor" diff --git a/library/platform/native/compiler.factor b/library/platform/native/compiler.factor new file mode 100644 index 0000000000..ba0286e20a --- /dev/null +++ b/library/platform/native/compiler.factor @@ -0,0 +1,90 @@ +IN: compiler +USE: math +USE: stack +USE: lists +USE: combinators +USE: words +USE: namespaces +USE: unparser +USE: errors +USE: strings +USE: logic +USE: kernel + +: DATASTACK + #! A pointer to a pointer to the datastack top. + 11 getenv ; + +: EAX 0 ; +: ECX 1 ; +: EDX 2 ; +: EBX 3 ; +: ESP 4 ; +: EBP 5 ; +: ESI 6 ; +: EDI 7 ; + +: I>R ( imm reg -- ) + #! MOV TO + HEX: a1 + compile-byte compile-cell ; + +: I>[R] ( imm reg -- ) + #! MOV TO ADDRESS + HEX: c7 compile-byte compile-byte compile-cell ; + +: I+[I] ( imm addr -- ) + #! ADD TO ADDRESS + HEX: 81 compile-byte + HEX: 05 compile-byte + compile-cell + compile-cell ; + +: LITERAL ( cell -- ) + #! Push literal on data stack. + DATASTACK EAX I>R EAX I>[R] 4 DATASTACK I+[I] ; + +: (JMP) ( xt opcode -- ) + #! JMP, CALL insn is 5 bytes long + #! addr is relative to *after* insn + compile-byte compile-offset 4 + - compile-cell ; + +: JMP HEX: e9 (JMP) ; +: CALL HEX: e8 (JMP) ; +: RET HEX: c3 compile-byte ; + +: compile-word ( word -- ) + #! Compile a JMP at the end (tail call optimization) + word-xt "compile-last" get [ JMP ] [ CALL ] ifte ; + +: compile-fixnum ( n -- ) + 3 shift 7 bitnot bitand LITERAL ; + +: compile-atom ( obj -- ) + [ + [ fixnum? ] [ compile-fixnum ] + [ word? ] [ compile-word ] + [ drop t ] [ "Cannot compile " swap unparse cat2 throw ] + ] cond ; + +: compile-loop ( quot -- ) + dup [ + unswons + over not "compile-last" set + compile-atom + compile-loop + ] [ + drop RET + ] ifte ; + +: compile-quot ( quot -- xt ) + [ + "compile-last" off + compile-offset swap compile-loop + ] with-scope ; + +: compile ( word -- ) + intern dup word-parameter compile-quot swap set-word-xt ; + +: call-xt ( xt -- ) + #! For testing. + 0 f f [ set-word-xt ] keep execute ; diff --git a/native/arithmetic.c b/native/arithmetic.c index ef3dcea339..f729f7c265 100644 --- a/native/arithmetic.c +++ b/native/arithmetic.c @@ -8,7 +8,7 @@ CELL tag_integer(FIXNUM x) return tag_fixnum(x); } -CELL tag_unsigned_integer(CELL x) +CELL tag_cell(CELL x) { if(x > FIXNUM_MAX) return tag_object(s48_ulong_to_bignum(x)); @@ -16,6 +16,20 @@ CELL tag_unsigned_integer(CELL x) return tag_fixnum(x); } +CELL to_cell(CELL x) +{ + switch(type_of(x)) + { + case FIXNUM_TYPE: + return untag_fixnum_fast(x); + case BIGNUM_TYPE: + /* really need bignum_to_ulong! */ + return s48_bignum_to_long(untag_bignum(x)); + default: + type_error(INTEGER_TYPE,x); + } +} + CELL upgraded_arithmetic_type(CELL type1, CELL type2) { switch(type1) diff --git a/native/arithmetic.h b/native/arithmetic.h index 2c716f0e57..3479736b7b 100644 --- a/native/arithmetic.h +++ b/native/arithmetic.h @@ -3,7 +3,8 @@ CELL upgraded_arithmetic_type(CELL type1, CELL type2); CELL tag_integer(FIXNUM x); -CELL tag_unsigned_integer(CELL x); +CELL tag_cell(CELL x); +CELL to_cell(CELL x); #define BINARY_OP(OP) \ CELL OP(CELL x, CELL y) \ diff --git a/native/compiler.c b/native/compiler.c new file mode 100644 index 0000000000..7497565095 --- /dev/null +++ b/native/compiler.c @@ -0,0 +1,23 @@ +#include "factor.h" + +void init_compiler(void) +{ + init_zone(&compiling,COMPILE_ZONE_SIZE); +} + +void primitive_compile_byte(void) +{ + bput(compiling.here,to_fixnum(dpop())); + compiling.here++; +} + +void primitive_compile_cell(void) +{ + put(compiling.here,to_cell(dpop())); + compiling.here += sizeof(CELL); +} + +void primitive_compile_offset(void) +{ + dpush(tag_integer(compiling.here)); +} diff --git a/native/compiler.h b/native/compiler.h new file mode 100644 index 0000000000..58beb1bd97 --- /dev/null +++ b/native/compiler.h @@ -0,0 +1,6 @@ +ZONE compiling; + +void init_compiler(void); +void primitive_compile_byte(void); +void primitive_compile_cell(void); +void primitive_compile_offset(void); diff --git a/native/factor.c b/native/factor.c index 9e4c1a87a9..58721fcc31 100644 --- a/native/factor.c +++ b/native/factor.c @@ -17,6 +17,7 @@ int main(int argc, char** argv) init_stacks(); init_io(); init_signals(); + init_compiler(); args = F; while(--argc != 0) diff --git a/native/factor.h b/native/factor.h index 7615cc3c9b..a8a4833d22 100644 --- a/native/factor.h +++ b/native/factor.h @@ -42,6 +42,7 @@ typedef unsigned char BYTE; /* Memory heap size */ #define DEFAULT_ARENA (5 * 1024 * 1024) +#define COMPILE_ZONE_SIZE (5 * 1024 * 1024) #define STACK_SIZE 16384 @@ -79,5 +80,6 @@ and allows profiling. */ #include "primitives.h" #include "vector.h" #include "stack.h" +#include "compiler.h" #endif /* __FACTOR_H__ */ diff --git a/native/memory.c b/native/memory.c index 67ee78c6fd..a73d28eea6 100644 --- a/native/memory.c +++ b/native/memory.c @@ -21,7 +21,7 @@ void* alloc_guarded(CELL size) void init_zone(ZONE* z, CELL size) { - z->base = z->here = align8((CELL)malloc(size)); + z->base = z->here = align8((CELL)alloc_guarded(size)); if(z->base == 0) fatal_error("Cannot allocate zone",size); z->limit = z->base + size; diff --git a/native/primitives.c b/native/primitives.c index 2efb548361..d41bce9b2d 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -88,6 +88,8 @@ XT primitives[] = { primitive_wordp, primitive_word, primitive_word_hashcode, + primitive_word_xt, + primitive_set_word_xt, primitive_word_primitive, primitive_set_word_primitive, primitive_word_parameter, @@ -150,7 +152,10 @@ XT primitives[] = { primitive_set_word_allot_count, primitive_dump, primitive_cwd, - primitive_cd + primitive_cd, + primitive_compile_byte, + primitive_compile_cell, + primitive_compile_offset }; CELL primitive_to_xt(CELL primitive) diff --git a/native/primitives.h b/native/primitives.h index 63e733c766..0171be5678 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,4 +1,4 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 150 +#define PRIMITIVE_COUNT 155 CELL primitive_to_xt(CELL primitive); diff --git a/native/run.h b/native/run.h index de773c5bc0..766eb2943d 100644 --- a/native/run.h +++ b/native/run.h @@ -11,6 +11,8 @@ #define BOOT_ENV 8 #define RUNQUEUE_ENV 9 /* used by library only */ #define ARGS_ENV 10 +#define DS_ENV 11 /* ptr to base addr of datastack */ +#define CS_ENV 12 /* ptr to base addr of callstack */ /* Profiling timer */ struct itimerval prof_timer; diff --git a/native/stack.c b/native/stack.c index 1534f52c9a..453768e1bd 100644 --- a/native/stack.c +++ b/native/stack.c @@ -14,8 +14,10 @@ void init_stacks(void) { ds_bot = (CELL)alloc_guarded(STACK_SIZE); reset_datastack(); + userenv[DS_ENV] = tag_integer((CELL)&ds); cs_bot = (CELL)alloc_guarded(STACK_SIZE); reset_callstack(); + userenv[CS_ENV] = tag_integer((CELL)&cs); callframe = userenv[BOOT_ENV]; } diff --git a/native/word.c b/native/word.c index 9c225052b5..37719c9b55 100644 --- a/native/word.c +++ b/native/word.c @@ -42,6 +42,17 @@ void primitive_word_hashcode(void) drepl(tag_fixnum(untag_word(dpeek())->hashcode)); } +void primitive_word_xt(void) +{ + drepl(tag_cell(untag_word(dpeek())->xt)); +} + +void primitive_set_word_xt(void) +{ + WORD* word = untag_word(dpop()); + word->xt = to_cell(dpop()); +} + void primitive_word_primitive(void) { drepl(tag_fixnum(untag_word(dpeek())->primitive)); @@ -78,7 +89,7 @@ void primitive_set_word_plist(void) void primitive_word_call_count(void) { - drepl(tag_unsigned_integer(untag_word(dpeek())->call_count)); + drepl(tag_cell(untag_word(dpeek())->call_count)); } void primitive_set_word_call_count(void) @@ -89,7 +100,7 @@ void primitive_set_word_call_count(void) void primitive_word_allot_count(void) { - drepl(tag_unsigned_integer(untag_word(dpeek())->allot_count)); + drepl(tag_cell(untag_word(dpeek())->allot_count)); } void primitive_set_word_allot_count(void) diff --git a/native/word.h b/native/word.h index d4623c94dd..307bb788b4 100644 --- a/native/word.h +++ b/native/word.h @@ -37,6 +37,8 @@ void primitive_word(void); void primitive_word_hashcode(void); void primitive_word_primitive(void); void primitive_set_word_primitive(void); +void primitive_word_xt(void); +void primitive_set_word_xt(void); void primitive_word_parameter(void); void primitive_set_word_parameter(void); void primitive_word_plist(void);