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 \
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:
- jedit ==> jedit-word, jedit takes a file name\r
- introduce ifte* and ?str-head/?str-tail where appropriate\r
- namespace clone drops static var bindings\r
-- solaris: -lsocket -lnsl\r
+<kc5tja> The binary register ordering, from 0 to 7, is EAX, ECX, EDX, EBX, ESP, EBP, ESI, EDI.\r
\r
+ bignums:\r
\r
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.
+
+\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.
+
+\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.
-namespaces are hashtables
+get example
-values, vars, vars-values
+describe
\subsection{The name stack}
USE: vectors
USE: words
+IN: compiler
+DEFER: compile-byte
+DEFER: compile-cell
+DEFER: compile-offset
+
IN: kernel
DEFER: getenv
DEFER: setenv
IN: words
DEFER: <word>
DEFER: word-hashcode
+DEFER: word-xt
+DEFER: set-word-xt
DEFER: word-primitive
DEFER: set-word-primitive
DEFER: word-parameter
word?
<word>
word-hashcode
+ word-xt
+ set-word-xt
word-primitive
set-word-primitive
word-parameter
dump
cwd
cd
+ compile-byte
+ compile-cell
+ compile-offset
] [
swap succ tuck primitive,
] each drop ;
"/library/telnetd.factor"
"/library/inferior.factor"
"/library/platform/native/profiler.factor"
+ "/library/platform/native/compiler.factor"
"/library/image.factor"
"/library/cross-compiler.factor"
--- /dev/null
+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 ;
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));
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)
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) \
--- /dev/null
+#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));
+}
--- /dev/null
+ZONE compiling;
+
+void init_compiler(void);
+void primitive_compile_byte(void);
+void primitive_compile_cell(void);
+void primitive_compile_offset(void);
init_stacks();
init_io();
init_signals();
+ init_compiler();
args = F;
while(--argc != 0)
/* Memory heap size */
#define DEFAULT_ARENA (5 * 1024 * 1024)
+#define COMPILE_ZONE_SIZE (5 * 1024 * 1024)
#define STACK_SIZE 16384
#include "primitives.h"
#include "vector.h"
#include "stack.h"
+#include "compiler.h"
#endif /* __FACTOR_H__ */
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;
primitive_wordp,
primitive_word,
primitive_word_hashcode,
+ primitive_word_xt,
+ primitive_set_word_xt,
primitive_word_primitive,
primitive_set_word_primitive,
primitive_word_parameter,
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)
extern XT primitives[];
-#define PRIMITIVE_COUNT 150
+#define PRIMITIVE_COUNT 155
CELL primitive_to_xt(CELL primitive);
#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;
{
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];
}
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));
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)
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)
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);
projects / factor.git / commitdiff