ref: ad4a0867906b9ac9ec7ceeb2e2b1ce2d5a156880
parent: 36a209cd5f648d4e7cdac062d8ecb321b561847d
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Wed Apr 15 23:05:38 EDT 2009
converting for to a special form adding loadi8 instruction cleaning up numeric comparison, reducing repeated code
--- 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)))
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -1204,39 +1204,66 @@
return return_from_uint64(Uaccum);
}
-static value_t fl_div2(value_t a, value_t b)
+static int num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp)
{- double da, db;
- int_t ai, bi;
- int ta, tb;
- void *aptr=NULL, *bptr=NULL;
cprim_t *cp;
-
if (isfixnum(a)) {- ai = numval(a);
- aptr = &ai;
- ta = T_FIXNUM;
+ *pi = numval(a);
+ *pp = pi;
+ *pt = T_FIXNUM;
}
else if (iscprim(a)) {cp = (cprim_t*)ptr(a);
- ta = cp_numtype(cp);
- if (ta <= T_DOUBLE)
- aptr = cp_data(cp);
+ *pp = cp_data(cp);
+ *pt = cp_numtype(cp);
}
- if (aptr == NULL)
- type_error("/", "number", a);- if (isfixnum(b)) {- bi = numval(b);
- bptr = &bi;
- tb = T_FIXNUM;
+ else {+ return 0;
}
- else if (iscprim(b)) {- cp = (cprim_t*)ptr(b);
- tb = cp_numtype(cp);
- if (tb <= T_DOUBLE)
- bptr = cp_data(cp);
+ 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 (bptr == NULL)
+ 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;
+ numerictype_t ta, tb;
+ void *aptr, *bptr;
+
+ if (!num_to_ptr(a, &ai, &ta, &aptr))
+ type_error("/", "number", a);+ if (!num_to_ptr(b, &bi, &tb, &bptr))
type_error("/", "number", b); if (ta == T_FLOAT) {@@ -1294,43 +1321,18 @@
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 @@
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 @@
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 @@
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);
--- a/femtolisp/equal.c
+++ b/femtolisp/equal.c
@@ -33,27 +33,6 @@
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 @@
return NIL;
int taga = tag(a);
int tagb = cmptag(b);
+ int c;
switch (taga) {case TAG_NUM :
case TAG_NUM1:
@@ -93,7 +73,7 @@
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 @@
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))
--- 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 @@
"+", "-", "*", "/", "=", "<", "compare",
// sequences
- "vector", "aref", "aset!", "for",
+ "vector", "aref", "aset!",
"", "", "" };
#define N_STACK 262144
@@ -649,33 +649,6 @@
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 @@
}
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 @@
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 @@
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 @@
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 @@
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++;
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -117,7 +117,8 @@
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 @@
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 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);
--- 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 @@
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
};
--- 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 "
; _
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -1017,12 +1017,13 @@
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
--- 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
+|#
--- a/llt/dtypes.h
+++ b/llt/dtypes.h
@@ -116,7 +116,7 @@
#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;