conservatory
/
femtolisp
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

converting for to a special form 

adding loadi8 instruction
cleaning up numeric comparison, reducing repeated code
This commit is contained in:
JeffBezanson 2009-04-16 03:05:38 +00:00
parent 36a209cd5f
commit ad4a086790
10 changed files with 172 additions and 171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
femtolisp/compiler.lsp
View File

@ -9,7 +9,7 @@
(define Instructions
(make-enum-table
[:nop :dup :pop :call :tcall :jmp :brf :brt :jmp.l :brf.l :brt.l :ret
:tapply
:tapply :for
:eq? :eqv? :equal? :atom? :not :null? :boolean? :symbol?
:number? :bound? :pair? :builtin? :vector? :fixnum?
@ -19,9 +19,9 @@
:+ :- :* :/ := :< :compare
:vector :aref :aset! :for
:vector :aref :aset!
:loadt :loadf :loadnil :load0 :load1 :loadv :loadv.l
:loadt :loadf :loadnil :load0 :load1 :loadi8 :loadv :loadv.l
:loadg :loada :loadc :loadg.l
:setg :seta :setc :setg.l
@ -39,9 +39,8 @@
:cdr 1 :set-car! 2
:set-cdr! 2 :eval 1
:apply 2 :< 2
:for 3 :compare 2
:aref 2 :aset! 3
:= 2))
:compare 2 :aref 2
:aset! 3 := 2))
(define 1/Instructions (table.invert Instructions))
@ -122,7 +121,7 @@
(set! i (+ i 1)))
((:loada :seta :call :tcall :loadv :loadg :setg
:list :+ :- :* :/ :vector :argc :vargc)
:list :+ :- :* :/ :vector :argc :vargc :loadi8)
(io.write bcode (uint8 nxt))
(set! i (+ i 1)))
@ -251,6 +250,21 @@
(emit g :jmp top)
(mark-label g end)))
(define (1arg-lambda? func)
(and (pair? func)
(eq? (car func) 'lambda)
(pair? (cdr func))
(pair? (cadr func))
(length= (cadr func) 1)))
(define (compile-for g env lo hi func)
(if (1arg-lambda? func)
(begin (compile-in g env #f lo)
(compile-in g env #f hi)
(compile-in g env #f func)
(emit g :for))
(error "for: third form must be a 1-argument lambda")))
(define (compile-short-circuit g env tail? forms default branch)
(cond ((atom? forms) (compile-in g env tail? default))
((atom? (cdr forms)) (compile-in g env tail? (car forms)))
@ -360,6 +374,9 @@
((eq? x #t) (emit g :loadt))
((eq? x #f) (emit g :loadf))
((eq? x ()) (emit g :loadnil))
((and (fixnum? x)
(>= x -128)
(<= x 127)) (emit g :loadi8 x))
(else (emit g :loadv x))))
(else
(case (car x)
@ -373,9 +390,12 @@
(and (compile-and g env tail? (cdr x)))
(or (compile-or g env tail? (cdr x)))
(while (compile-while g env (cadr x) (cons 'begin (cddr x))))
(for (compile-for g env (cadr x) (caddr x) (cadddr x)))
(set! (compile-in g env #f (caddr x))
(compile-sym g env (cadr x) [:seta :setc :setg]))
(trycatch (compile-in g env #f `(lambda () ,(cadr x)))
(unless (1arg-lambda? (caddr x))
(error "trycatch: second form must be a 1-argument lambda"))
(compile-in g env #f (caddr x))
(emit g :trycatch))
(else (compile-app g env tail? x))))))
@ -437,7 +457,7 @@
(set! i (+ i 1)))
((:loada :seta :call :tcall :list :+ :- :* :/ :vector
:argc :vargc)
:argc :vargc :loadi8)
(princ (number->string (aref code i)))
(set! i (+ i 1)))

124
femtolisp/cvalues.c
View File

@ -1204,39 +1204,66 @@ static value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum)
return return_from_uint64(Uaccum);
}
static int num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp)
{
cprim_t *cp;
if (isfixnum(a)) {
*pi = numval(a);
*pp = pi;
*pt = T_FIXNUM;
}
else if (iscprim(a)) {
cp = (cprim_t*)ptr(a);
*pp = cp_data(cp);
*pt = cp_numtype(cp);
}
else {
return 0;
}
return 1;
}
/*
returns -1, 0, or 1 based on ordering of a and b
eq: consider equality only, returning 0 or nonzero
eqnans: NaNs considered equal to each other
fname: if not NULL, throws type errors, else returns 2 for type errors
*/
int numeric_compare(value_t a, value_t b, int eq, int eqnans, char *fname)
{
int_t ai, bi;
numerictype_t ta, tb;
void *aptr, *bptr;
if (bothfixnums(a,b)) {
if (a==b) return 0;
if (numval(a) < numval(b)) return -1;
return 1;
}
if (!num_to_ptr(a, &ai, &ta, &aptr)) {
if (fname) type_error(fname, "number", a); else return 2;
}
if (!num_to_ptr(b, &bi, &tb, &bptr)) {
if (fname) type_error(fname, "number", b); else return 2;
}
if (cmp_eq(aptr, ta, bptr, tb, eqnans))
return 0;
if (eq) return 1;
if (cmp_lt(aptr, ta, bptr, tb))
return -1;
return 1;
}
static value_t fl_div2(value_t a, value_t b)
{
double da, db;
int_t ai, bi;
int ta, tb;
void *aptr=NULL, *bptr=NULL;
cprim_t *cp;
numerictype_t ta, tb;
void *aptr, *bptr;
if (isfixnum(a)) {
ai = numval(a);
aptr = &ai;
ta = T_FIXNUM;
}
else if (iscprim(a)) {
cp = (cprim_t*)ptr(a);
ta = cp_numtype(cp);
if (ta <= T_DOUBLE)
aptr = cp_data(cp);
}
if (aptr == NULL)
if (!num_to_ptr(a, &ai, &ta, &aptr))
type_error("/", "number", a);
if (isfixnum(b)) {
bi = numval(b);
bptr = &bi;
tb = T_FIXNUM;
}
else if (iscprim(b)) {
cp = (cprim_t*)ptr(b);
tb = cp_numtype(cp);
if (tb <= T_DOUBLE)
bptr = cp_data(cp);
}
if (bptr == NULL)
if (!num_to_ptr(b, &bi, &tb, &bptr))
type_error("/", "number", b);
if (ta == T_FLOAT) {
@ -1294,43 +1321,18 @@ static value_t fl_div2(value_t a, value_t b)
lerror(DivideError, "/: division by zero");
}
static void *int_data_ptr(value_t a, int *pnumtype, char *fname)
{
cprim_t *cp;
if (iscprim(a)) {
cp = (cprim_t*)ptr(a);
*pnumtype = cp_numtype(cp);
if (*pnumtype < T_FLOAT)
return cp_data(cp);
}
type_error(fname, "integer", a);
return NULL;
}
static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
{
int_t ai, bi;
int ta, tb, itmp;
numerictype_t ta, tb, itmp;
void *aptr=NULL, *bptr=NULL, *ptmp;
int64_t b64;
if (isfixnum(a)) {
ta = T_FIXNUM;
ai = numval(a);
aptr = &ai;
bptr = int_data_ptr(b, &tb, fname);
}
else {
aptr = int_data_ptr(a, &ta, fname);
if (isfixnum(b)) {
tb = T_FIXNUM;
bi = numval(b);
bptr = &bi;
}
else {
bptr = int_data_ptr(b, &tb, fname);
}
}
if (!num_to_ptr(a, &ai, &ta, &aptr) || ta >= T_FLOAT)
type_error(fname, "integer", a);
if (!num_to_ptr(b, &bi, &tb, &bptr) || tb >= T_FLOAT)
type_error(fname, "integer", b);
if (ta < tb) {
itmp = ta; ta = tb; tb = itmp;
ptmp = aptr; aptr = bptr; bptr = ptmp;
@ -1348,6 +1350,8 @@ static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
case T_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64);
case T_UINT64: return mk_uint64(*(uint64_t*)aptr & (uint64_t)b64);
case T_FLOAT:
case T_DOUBLE: assert(0);
}
break;
case 1:
@ -1360,6 +1364,8 @@ static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
case T_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64);
case T_UINT64: return mk_uint64(*(uint64_t*)aptr | (uint64_t)b64);
case T_FLOAT:
case T_DOUBLE: assert(0);
}
break;
case 2:
@ -1372,6 +1378,8 @@ static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
case T_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64);
case T_UINT64: return mk_uint64(*(uint64_t*)aptr ^ (uint64_t)b64);
case T_FLOAT:
case T_DOUBLE: assert(0);
}
}
assert(0);

41
femtolisp/equal.c
View File

@ -33,27 +33,6 @@ static void eq_union(htable_t *table, value_t a, value_t b,
ptrhash_put(table, (void*)b, (void*)ca);
}
// a is a fixnum, b is a cprim
static value_t compare_num_cprim(value_t a, value_t b, int eq, int swap)
{
cprim_t *bcp = (cprim_t*)ptr(b);
numerictype_t bt = cp_numtype(bcp);
fixnum_t ia = numval(a);
void *bptr = cp_data(bcp);
if (cmp_eq(&ia, T_FIXNUM, bptr, bt, 1))
return fixnum(0);
if (eq) return fixnum(1);
if (swap) {
if (cmp_lt(bptr, bt, &ia, T_FIXNUM))
return fixnum(-1);
}
else {
if (cmp_lt(&ia, T_FIXNUM, bptr, bt))
return fixnum(-1);
}
return fixnum(1);
}
static value_t bounded_compare(value_t a, value_t b, int bound, int eq);
static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq);
@ -86,6 +65,7 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
return NIL;
int taga = tag(a);
int tagb = cmptag(b);
int c;
switch (taga) {
case TAG_NUM :
case TAG_NUM1:
@ -93,7 +73,7 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1);
}
if (iscprim(b)) {
return compare_num_cprim(a, b, eq, 0);
return fixnum(numeric_compare(a, b, eq, 1, NULL));
}
return fixnum(-1);
case TAG_SYM:
@ -106,20 +86,9 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
return bounded_vector_compare(a, b, bound, eq);
break;
case TAG_CPRIM:
if (iscprim(b)) {
cprim_t *acp=(cprim_t*)ptr(a), *bcp=(cprim_t*)ptr(b);
numerictype_t at=cp_numtype(acp), bt=cp_numtype(bcp);
void *aptr=cp_data(acp), *bptr=cp_data(bcp);
if (cmp_eq(aptr, at, bptr, bt, 1))
return fixnum(0);
if (eq) return fixnum(1);
if (cmp_lt(aptr, at, bptr, bt))
return fixnum(-1);
return fixnum(1);
}
else if (isfixnum(b)) {
return compare_num_cprim(b, a, eq, 1);
}
c = numeric_compare(a, b, eq, 1, NULL);
if (c != 2)
return fixnum(c);
break;
case TAG_CVALUE:
if (iscvalue(b))

87
femtolisp/flisp.c
View File

@ -55,7 +55,7 @@
static char *builtin_names[] =
{ // special forms
"quote", "cond", "if", "and", "or", "while", "lambda",
"trycatch", "%apply", "%applyn", "set!", "prog1", "begin",
"trycatch", "%apply", "%applyn", "set!", "prog1", "for", "begin",
// predicates
"eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
@ -71,7 +71,7 @@ static char *builtin_names[] =
"+", "-", "*", "/", "=", "<", "compare",
// sequences
"vector", "aref", "aset!", "for",
"vector", "aref", "aset!",
"", "", "" };
#define N_STACK 262144
@ -649,33 +649,6 @@ int isnumber(value_t v)
return (isfixnum(v) || iscprim(v));
}
static int numeric_equals(value_t a, value_t b)
{
value_t tmp;
if (isfixnum(b)) {
tmp=a; a=b; b=tmp;
}
void *aptr, *bptr;
numerictype_t at, bt;
if (!iscprim(b)) type_error("=", "number", b);
cprim_t *cp = (cprim_t*)ptr(b);
fixnum_t fv;
bt = cp_numtype(cp);
bptr = cp_data(cp);
if (isfixnum(a)) {
fv = numval(a);
at = T_FIXNUM;
aptr = &fv;
}
else if (iscprim(a)) {
cp = (cprim_t*)ptr(a);
at = cp_numtype(cp);
aptr = cp_data(cp);
}
else type_error("=", "number", a);
return cmp_eq(aptr, at, bptr, bt, 0);
}
// read -----------------------------------------------------------------------
#include "read.c"
@ -1079,6 +1052,35 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
}
v = POP();
break;
case F_FOR:
if (!iscons(Stack[bp])) goto notpair;
v = car_(Stack[bp]);
lo = tofixnum(eval(v), "for");
Stack[bp] = cdr_(Stack[bp]);
if (!iscons(Stack[bp])) goto notpair;
v = car_(Stack[bp]);
hi = tofixnum(eval(v), "for");
Stack[bp] = cdr_(Stack[bp]);
if (!iscons(Stack[bp])) goto notpair;
v = car_(Stack[bp]);
f = eval(v);
v = car(cdr(f));
if (!iscons(v) || !iscons(cdr_(cdr_(f))) || cdr_(v) != NIL ||
car_(f) != LAMBDA)
lerror(ArgError, "for: expected 1 argument lambda");
f = cdr_(f);
PUSH(f); // save function cdr
SP += 3; // make space
Stack[SP-1] = cdr_(cdr_(f)); // cloenv
v = FL_F;
for(s=lo; s <= hi; s++) {
f = Stack[SP-4];
Stack[SP-3] = car_(f); // lambda list
Stack[SP-2] = fixnum(s); // argument value
v = car_(cdr_(f));
if (!selfevaluating(v)) v = eval_sexpr(v, &Stack[SP-3], 0, 3);
}
break;
case F_TRYCATCH:
v = do_trycatch(car(Stack[bp]), penv, envsz);
break;
@ -1323,7 +1325,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
v = (v == e) ? FL_T : FL_F;
}
else {
v = numeric_equals(v, e) ? FL_T : FL_F;
v = (!numeric_compare(v,e,1,0,"=")) ? FL_T : FL_F;
}
break;
case F_LT:
@ -1380,28 +1382,6 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
penv = &Stack[SP-2];
}
goto eval_top;
case F_FOR:
argcount("for", nargs, 3);
lo = tofixnum(Stack[SP-3], "for");
hi = tofixnum(Stack[SP-2], "for");
f = Stack[SP-1];
v = car(cdr(f));
if (!iscons(v) || !iscons(cdr_(cdr_(f))) || cdr_(v) != NIL ||
car_(f) != LAMBDA)
lerror(ArgError, "for: expected 1 argument lambda");
f = cdr_(f);
PUSH(f); // save function cdr
SP += 3; // make space
Stack[SP-1] = cdr_(cdr_(f)); // cloenv
v = FL_F;
for(s=lo; s <= hi; s++) {
f = Stack[SP-4];
Stack[SP-3] = car_(f); // lambda list
Stack[SP-2] = fixnum(s); // argument value
v = car_(cdr_(f));
if (!selfevaluating(v)) v = eval_sexpr(v, &Stack[SP-3], 0, 3);
}
break;
case F_SPECIAL_APPLYN:
POPN(4);
v = POP();
@ -1900,7 +1880,7 @@ static value_t apply_cl(uint32_t nargs)
v = (v == e) ? FL_T : FL_F;
}
else {
v = numeric_equals(v, e) ? FL_T : FL_F;
v = (!numeric_compare(v,e,1,0,"=")) ? FL_T : FL_F;
}
POPN(1);
Stack[SP-1] = v;
@ -1996,6 +1976,7 @@ static value_t apply_cl(uint32_t nargs)
case OP_LOADNIL: PUSH(NIL); break;
case OP_LOAD0: PUSH(fixnum(0)); break;
case OP_LOAD1: PUSH(fixnum(1)); break;
case OP_LOADI8: s = (int8_t)code[ip++]; PUSH(fixnum(s)); break;
case OP_LOADV:
assert(code[ip] < vector_size(*pvals));
v = vector_elt(*pvals, code[ip]); ip++;

6
femtolisp/flisp.h
View File

@ -117,7 +117,8 @@ extern uint32_t SP;
enum {
// special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA,
F_TRYCATCH, F_SPECIAL_APPLY, F_SPECIAL_APPLYN, F_SETQ, F_PROG1, F_BEGIN,
F_TRYCATCH, F_SPECIAL_APPLY, F_SPECIAL_APPLYN, F_SETQ, F_PROG1, F_FOR,
F_BEGIN,
// functions
F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP,
@ -127,7 +128,7 @@ enum {
F_EVAL, F_APPLY,
F_ADD, F_SUB, F_MUL, F_DIV, F_NUMEQ, F_LT, F_COMPARE,
F_VECTOR, F_AREF, F_ASET, F_FOR,
F_VECTOR, F_AREF, F_ASET,
F_TRUE, F_FALSE, F_NIL,
N_BUILTINS
};
@ -292,6 +293,7 @@ int isstring(value_t v);
int isnumber(value_t v);
int isiostream(value_t v);
value_t cvalue_compare(value_t a, value_t b);
int numeric_compare(value_t a, value_t b, int eq, int eqnans, char *fname);
void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz);

10
femtolisp/opcodes.h
View File

@ -3,7 +3,7 @@
enum {
OP_NOP=0, OP_DUP, OP_POP, OP_CALL, OP_TCALL, OP_JMP, OP_BRF, OP_BRT,
OP_JMPL, OP_BRFL, OP_BRTL, OP_RET, OP_TAPPLY,
OP_JMPL, OP_BRFL, OP_BRTL, OP_RET, OP_TAPPLY, OP_FOR,
OP_EQ, OP_EQV, OP_EQUAL, OP_ATOMP, OP_NOT, OP_NULLP, OP_BOOLEANP,
OP_SYMBOLP, OP_NUMBERP, OP_BOUNDP, OP_PAIRP, OP_BUILTINP, OP_VECTORP,
@ -14,11 +14,11 @@ enum {
OP_ADD, OP_SUB, OP_MUL, OP_DIV, OP_NUMEQ, OP_LT, OP_COMPARE,
OP_VECTOR, OP_AREF, OP_ASET, OP_FOR,
OP_VECTOR, OP_AREF, OP_ASET,
OP_LOADT, OP_LOADF, OP_LOADNIL, OP_LOAD0, OP_LOAD1, OP_LOADV, OP_LOADVL,
OP_LOADG, OP_LOADA, OP_LOADC, OP_LOADGL, OP_SETG, OP_SETA, OP_SETC,
OP_SETGL,
OP_LOADT, OP_LOADF, OP_LOADNIL, OP_LOAD0, OP_LOAD1, OP_LOADI8,
OP_LOADV, OP_LOADVL, OP_LOADG, OP_LOADA, OP_LOADC, OP_LOADGL,
OP_SETG, OP_SETA, OP_SETC, OP_SETGL,
OP_CLOSURE, OP_TRYCATCH, OP_ARGC, OP_VARGC
};

4
femtolisp/system.lsp
View File

@ -661,8 +661,8 @@
(io.close F)
(raise `(load-error ,filename ,e)))))))
;(load (string *install-dir* *directory-separator* "compiler.lsp"))
;(define (load-process x) ((compile-thunk (expand x))))
(load (string *install-dir* *directory-separator* "compiler.lsp"))
(define (load-process x) ((compile-thunk (expand x))))
(define *banner* (string.tail "
; _

7
femtolisp/todo
View File

@ -1017,12 +1017,13 @@ typedef struct _fltype_t {
new evaluator todo:
- need builtin = to handle nans properly, fix equal? on nans
* need builtin = to handle nans properly, fix equal? on nans
- builtin quasi-opaque function type
fields: signature, maxstack, bcode, vals, cloenv
function->vector
- make (for ...) a special form
- trycatch should require 2nd arg to be a lambda expression
* make (for ...) a special form
* trycatch should require 2nd arg to be a lambda expression
* immediate load int8 instruction
- maxstack calculation, replace Stack with C stack, alloca
- stack traces and better debugging support
- lambda lifting

26
femtolisp/wt.lsp
View File

@ -1,8 +1,28 @@
(set! i 0)
(define-macro (while- test . forms)
`((label -loop- (lambda ()
(if ,test
(begin ,@forms
(-loop-))
nil)))))
(while (< i 10000000) (set! i (+ i 1)))
())))))
(define (tw)
(set! i 0)
(while (< i 10000000) (set! i (+ i 1))))
(define (tw2)
(letrec ((loop (lambda ()
(if (< i 10000000)
(begin (set! i (+ i 1))
(loop))
()))))
(loop)))
#|
interpreter:
while: 1.82sec
macro: 2.98sec
compiler:
while: 0.72sec
macro: 1.24sec
|#

2
llt/dtypes.h
View File

@ -116,7 +116,7 @@ typedef u_ptrint_t uptrint_t;
#define LABS(n) (((n)^((n)>>(NBITS-1))) - ((n)>>(NBITS-1)))
#define NBABS(n,nb) (((n)^((n)>>((nb)-1))) - ((n)>>((nb)-1)))
#define DFINITE(d) (((*(int64_t*)&(d))&0x7ff0000000000000LL)!=0x7ff0000000000000LL)
#define DNAN(d) (((*(int64_t*)&(d))&0x7ff8000000000000LL)==0x7ff8000000000000LL)
#define DNAN(d) ((d)!=(d))
extern double D_PNAN;
extern double D_NNAN;