diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index 7719f6f..65b49e0 100644 --- a/femtolisp/compiler.lsp +++ b/femtolisp/compiler.lsp @@ -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))) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index c72b552..b9b6e0d 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -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); diff --git a/femtolisp/equal.c b/femtolisp/equal.c index f7f40c8..aac2461 100644 --- a/femtolisp/equal.c +++ b/femtolisp/equal.c @@ -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)) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 473f497..cfcb232 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -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++; diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index fb12d01..61ff81a 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -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); diff --git a/femtolisp/opcodes.h b/femtolisp/opcodes.h index bcd4015..e53297a 100644 --- a/femtolisp/opcodes.h +++ b/femtolisp/opcodes.h @@ -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 }; diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index a61caef..9b1ccc2 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -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 " ; _ diff --git a/femtolisp/todo b/femtolisp/todo index ec91681..acfe243 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -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 diff --git a/femtolisp/wt.lsp b/femtolisp/wt.lsp index 31183d3..a0b8888 100644 --- a/femtolisp/wt.lsp +++ b/femtolisp/wt.lsp @@ -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 +|# diff --git a/llt/dtypes.h b/llt/dtypes.h index 6dd154d..4bd890b 100644 --- a/llt/dtypes.h +++ b/llt/dtypes.h @@ -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;