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

adding some combined instructions and teaching the compiler to emit them: 

brn, brnn, brne, cadr
This commit is contained in:
JeffBezanson 2009-07-24 04:20:09 +00:00
parent 88d08edecc
commit c61dc10002
5 changed files with 95 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
femtolisp/compiler.lsp
View File

@ -25,6 +25,7 @@
:closure :argc :vargc :trycatch :copyenv :let :for :tapply
:add2 :sub2 :neg :largc :lvargc
:loada0 :loada1 :loadc00 :loadc01 :call.l :tcall.l
:brne :brne.l :cadr :brnn :brnn.l :brn :brn.l
dummy_t dummy_f dummy_nil]))
(for 0 (1- (length keys))
@ -62,7 +63,10 @@
(aset! b 2 (+ nconst 1)))))))
(define (emit e inst . args)
(if (null? args)
(aset! e 0 (cons inst (aref e 0)))
(if (and (eq? inst :car) (pair? (aref e 0))
(eq? (car (aref e 0)) :cdr))
(set-car! (aref e 0) :cadr)
(aset! e 0 (cons inst (aref e 0))))
(begin
(if (memq inst '(:loadv :loadg :setg))
(set! args (list (bcode:indexfor e (car args)))))
@ -92,7 +96,23 @@
((equal? args '(0 1))
(set! inst :loadc01)
(set! args ()))))
(aset! e 0 (nreconc (cons inst args) (aref e 0)))))
(let ((lasti (if (pair? (aref e 0))
(car (aref e 0)) ()))
(bc (aref e 0)))
(cond ((and (eq? inst :brf) (eq? lasti :not)
(eq? (cadr bc) :null?))
(aset! e 0 (cons (car args) (cons :brn (cddr bc)))))
((and (eq? inst :brf) (eq? lasti :not))
(aset! e 0 (cons (car args) (cons :brt (cdr bc)))))
((and (eq? inst :brf) (eq? lasti :eq?))
(aset! e 0 (cons (car args) (cons :brne (cdr bc)))))
((and (eq? inst :brf) (eq? lasti :null?))
(aset! e 0 (cons (car args) (cons :brnn (cdr bc)))))
((and (eq? inst :brt) (eq? lasti :null?))
(aset! e 0 (cons (car args) (cons :brn (cdr bc)))))
(else
(aset! e 0 (nreconc (cons inst args) bc)))))))
e)
(define (make-label e) (gensym))
@ -134,14 +154,17 @@
(get Instructions
(if long?
(case vi
(:jmp :jmp.l)
(:brt :brt.l)
(:brf :brf.l)
(:jmp :jmp.l)
(:brt :brt.l)
(:brf :brf.l)
(:brne :brne.l)
(:brnn :brnn.l)
(:brn :brn.l)
(else vi))
vi))))
(set! i (+ i 1))
(set! nxt (if (< i n) (aref v i) #f))
(cond ((memq vi '(:jmp :brf :brt))
(cond ((memq vi '(:jmp :brf :brt :brne :brnn :brn))
(put! fixup-to-label (sizeof bcode) nxt)
(io.write bcode ((if long? int32 int16) 0))
(set! i (+ i 1)))
@ -400,12 +423,19 @@
(emit g (if tail? :tcall.l :call.l) nargs)))
(let ((b (and (builtin? head)
(builtin->instruction head))))
(if (not b)
(compile-in g env #f head))
(let ((nargs (compile-arglist g env (cdr x))))
(if b
(compile-builtin-call g env tail? x head b nargs)
(emit g (if tail? :tcall :call) nargs))))))))
(if (and (eq? head 'cadr)
(not (in-env? head env))
(equal? (top-level-value 'cadr) cadr)
(length= x 2))
(begin (compile-in g env #f (cadr x))
(emit g :cadr))
(begin
(if (not b)
(compile-in g env #f head))
(let ((nargs (compile-arglist g env (cdr x))))
(if b
(compile-builtin-call g env tail? x head b nargs)
(emit g (if tail? :tcall :call) nargs))))))))))
(define (expand-define form body)
(if (symbol? form)
@ -590,11 +620,11 @@
(princ (number->string (ref-int32-LE code i)))
(set! i (+ i 4)))
((:jmp :brf :brt)
((:jmp :brf :brt :brne :brnn :brn)
(princ "@" (hex5 (+ i -4 (ref-int16-LE code i))))
(set! i (+ i 2)))
((:jmp.l :brf.l :brt.l)
((:jmp.l :brf.l :brt.l :brne.l :brnn.l :brn.l)
(princ "@" (hex5 (+ i -4 (ref-int32-LE code i))))
(set! i (+ i 4)))

2
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

37
femtolisp/flisp.c
View File

@ -1062,6 +1062,36 @@ static value_t apply_cl(uint32_t nargs)
if (v != FL_F) ip += (ptrint_t)GET_INT32(ip);
else ip += 4;
NEXT_OP;
OP(OP_BRNE)
if (Stack[SP-2] != Stack[SP-1]) ip += (ptrint_t)GET_INT16(ip);
else ip += 2;
POPN(2);
NEXT_OP;
OP(OP_BRNEL)
if (Stack[SP-2] != Stack[SP-1]) ip += (ptrint_t)GET_INT32(ip);
else ip += 4;
POPN(2);
NEXT_OP;
OP(OP_BRNN)
v = POP();
if (v != NIL) ip += (ptrint_t)GET_INT16(ip);
else ip += 2;
NEXT_OP;
OP(OP_BRNNL)
v = POP();
if (v != NIL) ip += (ptrint_t)GET_INT32(ip);
else ip += 4;
NEXT_OP;
OP(OP_BRN)
v = POP();
if (v == NIL) ip += (ptrint_t)GET_INT16(ip);
else ip += 2;
NEXT_OP;
OP(OP_BRNL)
v = POP();
if (v == NIL) ip += (ptrint_t)GET_INT32(ip);
else ip += 4;
NEXT_OP;
OP(OP_RET)
v = POP();
SP = curr_frame;
@ -1152,6 +1182,13 @@ static value_t apply_cl(uint32_t nargs)
if (!iscons(v)) type_error("cdr", "cons", v);
Stack[SP-1] = cdr_(v);
NEXT_OP;
OP(OP_CADR)
v = Stack[SP-1];
if (!iscons(v)) type_error("cdr", "cons", v);
v = cdr_(v);
if (!iscons(v)) type_error("car", "cons", v);
Stack[SP-1] = car_(v);
NEXT_OP;
OP(OP_SETCAR)
car(Stack[SP-2]) = Stack[SP-1];
POPN(1); NEXT_OP;

4
femtolisp/opcodes.h
View File

@ -26,6 +26,7 @@ enum {
OP_CLOSURE, OP_ARGC, OP_VARGC, OP_TRYCATCH, OP_COPYENV, OP_LET, OP_FOR,
OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_LARGC, OP_LVARGC,
OP_LOADA0, OP_LOADA1, OP_LOADC00, OP_LOADC01, OP_CALLL, OP_TCALLL,
OP_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL,
OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
@ -67,7 +68,8 @@ enum {
&&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, &&L_OP_NEG, &&L_OP_LARGC, \
&&L_OP_LVARGC, \
&&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01, \
&&L_OP_CALLL, &&L_OP_TCALLL \
&&L_OP_CALLL, &&L_OP_TCALLL, &&L_OP_BRNE, &&L_OP_BRNEL, &&L_OP_CADR,\
&&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL \
}
#define VM_APPLY_LABELS \

12
femtolisp/todo
View File

@ -1053,9 +1053,17 @@ new evaluator todo:
- opcodes CAAR, CADR, CDAR, CDDR
- EQTO N, compare directly to stored datum N
- peephole opt
done:
not brf => brt
eq brf => brne
null brf => brnn
null brt => brn
null not brf => brn
cdr car => cadr
not yet:
not brt => brf
constant+pop => nothing, e.g. 2-arg 'if' in statement position
not+brf => brt
not+brt => brf
loadt+brf => nothing
loadf+brt => nothing
loadt+brt => jmp