started x86 compiler

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:

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
+<kc5tja> The binary register ordering, from 0 to 7, is EAX, ECX, EDX, EBX, ESP, EBP, ESI, EDI.
 
 + bignums:
 

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> ( -{}- namespace )} creates a new namespace object. Actually, a namespace is just a hashtable, with a default capacity.
+
+\texttt{with-scope ( quot -{}- )} combines \texttt{<namespace>} with \texttt{bind} by executing a quotation in a new namespace.
+
+get example
+
+describe
 
 \subsection{The name stack}
 

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: <word>
 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>
         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 ;

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"

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 <imm> TO <reg>
+    HEX: a1 + compile-byte  compile-cell ;
+
+: I>[R] ( imm reg -- )
+    #! MOV <imm> TO ADDRESS <reg>
+    HEX: c7 compile-byte  compile-byte  compile-cell ;
+
+: I+[I] ( imm addr -- )
+    #! ADD <imm> TO ADDRESS <addr>
+    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 <word> [ set-word-xt ] keep execute ;

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)

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) \

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));
+}

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);

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)

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__ */

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;

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)

native/primitives.h

@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 150
+#define PRIMITIVE_COUNT 155
 
 CELL primitive_to_xt(CELL primitive);

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;

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];
 }
 

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)

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);