lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

finishing initial implementation of keyword arguments 

fixing up interpreter so it can be used for bootstrapping again
removing let/copyenv optimization because it really didn't seem to help much
This commit is contained in:
JeffBezanson 2009-08-02 04:06:07 +00:00
parent adb702cdf8
commit 15c8cb327d
7 changed files with 162 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

133
femtolisp/compiler.lsp
View File

@ -22,11 +22,11 @@
setg setg.l
seta seta.l setc setc.l
closure argc vargc trycatch copyenv let for tapply
closure argc vargc trycatch 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
optargs brbound
optargs brbound keyargs
dummy_t dummy_f dummy_nil]))
(for 0 (1- (length keys))
@ -101,15 +101,18 @@
(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)))))
(cond ((and
(eq? inst 'brf)
(cond ((and (eq? lasti 'not)
(eq? (cadr bc) 'null?))
(aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
((eq? lasti 'not)
(aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
((eq? lasti 'eq?)
(aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
((eq? lasti 'null?)
(aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
(else #f))))
((and (eq? inst 'brt) (eq? lasti 'null?))
(aset! e 0 (cons (car args) (cons 'brn (cdr bc)))))
(else
@ -182,11 +185,14 @@
(io.write bcode (uint8 (aref v i)))
(set! i (+ i 1)))
((loadc.l setc.l optargs) ; 2 int32 args
((loadc.l setc.l optargs keyargs) ; 2 int32 args
(io.write bcode (int32 nxt))
(set! i (+ i 1))
(io.write bcode (int32 (aref v i)))
(set! i (+ i 1)))
(set! i (+ i 1))
(if (eq? vi 'keyargs)
(begin (io.write bcode (int32 (aref v i)))
(set! i (+ i 1)))))
(else
; other number arguments are always uint8
@ -343,26 +349,7 @@
" arguments.")))
(define (compile-app g env tail? x)
(let ((head (car x)))
(if (and (pair? head)
(eq? (car head) 'lambda)
(list? (cadr head))
(every symbol? (cadr head))
(not (length> (cadr head) 255)))
(compile-let g env tail? x)
(compile-call g env tail? x))))
(define (compile-let g env tail? x)
(let ((head (car x))
(args (cdr x)))
(unless (length= args (length (cadr head)))
(error "apply: incorrect number of arguments to " head))
(receive (the-f dept) (compile-f- env head #t)
(emit g 'loadv the-f)
(bcode:cdepth g dept))
(let ((nargs (compile-arglist g env args)))
(emit g 'copyenv)
(emit g (if tail? 'tcall 'call) (+ 1 nargs)))))
(compile-call g env tail? x))
(define builtin->instruction
(let ((b2i (table number? 'number? cons 'cons
@ -485,9 +472,9 @@
(emit g 'trycatch))
(else (compile-app g env tail? x))))))
(define (compile-f env f . let?)
(define (compile-f env f)
(receive (ff ignore)
(apply compile-f- env f let?)
(compile-f- env f)
ff))
(define get-defined-vars
@ -507,6 +494,13 @@
(else ())))))
(lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
(define (keyword-arg? x) (and (pair? x) (keyword? (car x))))
(define (keyword->symbol k)
(if (keyword? k)
(symbol (let ((s (string k)))
(string.sub s 0 (string.dec s (length s)))))
k))
(define (lambda-vars l)
(define (check-formals l o)
(or
@ -517,7 +511,12 @@
(and (pair? (car l))
(or (every pair? (cdr l))
(error "compile error: invalid argument list "
o ". optional arguments must come last.")))
o ". optional arguments must come after required."))
(if (keyword? (caar l))
(or (every keyword-arg? (cdr l))
(error "compile error: invalid argument list "
o ". keyword arguments must come last."))
#t))
(error "compile error: invalid formal argument " (car l)
" in list " o))
(check-formals (cdr l) o))
@ -525,8 +524,8 @@
(error "compile error: invalid argument list " o)
(error "compile error: invalid formal argument " l " in list " o))))
(check-formals l l)
(map (lambda (s) (if (pair? s) (car s) s))
(to-proper l)))
(map! (lambda (s) (if (pair? s) (keyword->symbol (car s)) s))
(to-proper l)))
(define (emit-optional-arg-inits g env opta vars i)
; i is the lexical var index of the opt arg to process next
@ -547,7 +546,7 @@
(lambda (expr)
(compile `(lambda () ,expr . ,*defines-processed-token*))))
(lambda (env f . let?)
(lambda (env f)
; convert lambda to one body expression and process internal defines
(define (lambda-body e)
(let ((B (if (pair? (cddr e))
@ -570,15 +569,25 @@
'lambda
(lastcdr f))))
(let* ((nargs (if (atom? args) 0 (length args)))
(nreq (- nargs (length opta))))
(nreq (- nargs (length opta)))
(kwa (filter keyword-arg? opta)))
; emit argument checking prologue
(if (not (null? opta))
(begin (emit g 'optargs nreq (if (null? atail) nargs (- nargs)))
(emit-optional-arg-inits g env opta vars nreq)))
(begin
(if (null? kwa)
(emit g 'optargs nreq
(if (null? atail) nargs (- nargs)))
(begin
(bcode:indexfor g (make-perfect-hash-table
(map cons
(map car kwa)
(iota (length kwa)))))
(emit g 'keyargs nreq (length kwa)
(if (null? atail) nargs (- nargs)))))
(emit-optional-arg-inits g env opta vars nreq)))
(cond ((not (null? let?)) (emit g 'let))
((> nargs 255) (emit g (if (null? atail)
(cond ((> nargs 255) (emit g (if (null? atail)
'largc 'lvargc)
nargs))
((not (null? atail)) (emit g 'vargc nargs))
@ -661,11 +670,16 @@
(princ (number->string (aref code i)))
(set! i (+ i 1)))
((loadc.l setc.l optargs)
((loadc.l setc.l optargs keyargs)
(princ (number->string (ref-int32-LE code i)) " ")
(set! i (+ i 4))
(princ (number->string (ref-int32-LE code i)))
(set! i (+ i 4)))
(set! i (+ i 4))
(if (eq? inst 'keyargs)
(begin
(princ " ")
(princ (number->string (ref-int32-LE code i)) " ")
(set! i (+ i 4)))))
((brbound)
(princ (number->string (ref-int32-LE code i)) " ")
@ -683,4 +697,31 @@
(else #f)))))))
; From SRFI 89 by Marc Feeley (http://srfi.schemers.org/srfi-89/srfi-89.html)
; Copyright (C) Marc Feeley 2006. All Rights Reserved.
;
; "alist" is a list of pairs of the form "(keyword . value)"
; The result is a perfect hash-table represented as a vector of
; length 2*N, where N is the hash modulus. If the keyword K is in
; the hash-table it is at index
;
; X = (* 2 ($hash-keyword K N))
;
; and the associated value is at index X+1.
(define (make-perfect-hash-table alist)
(define ($hash-keyword key n) (mod0 (abs (hash key)) n))
(let loop1 ((n (length alist)))
(let ((v (vector.alloc (* 2 n) #f)))
(let loop2 ((lst alist))
(if (pair? lst)
(let ((key (caar lst)))
(let ((x (* 2 ($hash-keyword key n))))
(if (aref v x)
(loop1 (+ n 1))
(begin
(aset! v x key)
(aset! v (+ x 1) (cdar lst))
(loop2 (cdr lst))))))
v)))))
#t

2
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

107
femtolisp/flisp.c
View File

@ -391,7 +391,7 @@ void fl_gc_handle(value_t *pv)
GCHandleStack[N_GCHND++] = pv;
}
void fl_free_gc_handles(int n)
void fl_free_gc_handles(uint32_t n)
{
assert(N_GCHND >= n);
N_GCHND -= n;
@ -826,11 +826,11 @@ static uint32_t process_keys(value_t kwtable,
lerrorf(ArgError, "keyword %s requires an argument",
symbol_name(v));
value_t hv = fixnum(((symbol_t*)ptr(v))->hash);
uint32_t x = 2*(numval(hv) % n);
uint32_t x = 2*(abs(numval(hv)) % n);
if (vector_elt(kwtable, x) == v) {
uint32_t idx = numval(vector_elt(kwtable, x+1));
assert(idx < nkw);
idx += (nreq+nopt);
idx += nopt;
if (args[idx] == UNBOUND) {
// if duplicate key, keep first value
args[idx] = Stack[bp+i];
@ -995,40 +995,6 @@ static value_t apply_cl(uint32_t nargs)
OP(OP_LVARGC)
i = GET_INT32(ip); ip+=4;
goto do_vargc;
OP(OP_LET)
// last arg is closure environment to use
nargs--;
Stack[SP-5] = Stack[SP-4];
Stack[SP-4] = nargs;
POPN(1);
Stack[SP-1] = 0;
curr_frame = SP;
NEXT_OP;
OP(OP_OPTARGS)
i = GET_INT32(ip); ip+=4;
n = GET_INT32(ip); ip+=4;
if (nargs < i)
lerror(ArgError, "apply: too few arguments");
if ((int32_t)n > 0) {
if (nargs > n)
lerror(ArgError, "apply: too many arguments");
}
else n = -n;
if (n > nargs) {
n -= nargs;
SP += n;
Stack[SP-1] = Stack[SP-n-1];
Stack[SP-2] = Stack[SP-n-2];
Stack[SP-3] = nargs+n;
Stack[SP-4] = Stack[SP-n-4];
Stack[SP-5] = Stack[SP-n-5];
curr_frame = SP;
for(i=0; i < n; i++) {
Stack[bp+nargs+i] = UNBOUND;
}
nargs += n;
}
NEXT_OP;
OP(OP_BRBOUND)
i = GET_INT32(ip); ip+=4;
if (captured)
@ -1038,7 +1004,6 @@ static value_t apply_cl(uint32_t nargs)
if (v != UNBOUND) ip += (ptrint_t)GET_INT32(ip);
else ip += 4;
NEXT_OP;
OP(OP_NOP) NEXT_OP;
OP(OP_DUP) SP++; Stack[SP-1] = Stack[SP-2]; NEXT_OP;
OP(OP_POP) POPN(1); NEXT_OP;
OP(OP_TCALL)
@ -1716,7 +1681,6 @@ static value_t apply_cl(uint32_t nargs)
NEXT_OP;
OP(OP_CLOSURE)
OP(OP_COPYENV)
// build a closure (lambda args body . env)
if (nargs > 0 && !captured) {
// save temporary environment to the heap
@ -1737,17 +1701,15 @@ static value_t apply_cl(uint32_t nargs)
else {
PUSH(Stack[bp]); // env has already been captured; share
}
if (ip[-1] == OP_CLOSURE) {
pv = alloc_words(4);
e = Stack[SP-2]; // closure to copy
assert(isfunction(e));
pv[0] = ((value_t*)ptr(e))[0];
pv[1] = ((value_t*)ptr(e))[1];
pv[2] = Stack[SP-1]; // env
pv[3] = ((value_t*)ptr(e))[3];
POPN(1);
Stack[SP-1] = tagptr(pv, TAG_FUNCTION);
}
pv = alloc_words(4);
e = Stack[SP-2]; // closure to copy
assert(isfunction(e));
pv[0] = ((value_t*)ptr(e))[0];
pv[1] = ((value_t*)ptr(e))[1];
pv[2] = Stack[SP-1]; // env
pv[3] = ((value_t*)ptr(e))[3];
POPN(1);
Stack[SP-1] = tagptr(pv, TAG_FUNCTION);
NEXT_OP;
OP(OP_TRYCATCH)
@ -1756,6 +1718,40 @@ static value_t apply_cl(uint32_t nargs)
Stack[SP-1] = v;
NEXT_OP;
OP(OP_OPTARGS)
i = GET_INT32(ip); ip+=4;
n = GET_INT32(ip); ip+=4;
if (nargs < i)
lerror(ArgError, "apply: too few arguments");
if ((int32_t)n > 0) {
if (nargs > n)
lerror(ArgError, "apply: too many arguments");
}
else n = -n;
if (n > nargs) {
n -= nargs;
SP += n;
Stack[SP-1] = Stack[SP-n-1];
Stack[SP-2] = Stack[SP-n-2];
Stack[SP-3] = nargs+n;
Stack[SP-4] = Stack[SP-n-4];
Stack[SP-5] = Stack[SP-n-5];
curr_frame = SP;
for(i=0; i < n; i++) {
Stack[bp+nargs+i] = UNBOUND;
}
nargs += n;
}
NEXT_OP;
OP(OP_KEYARGS)
v = fn_vals(Stack[bp-1]);
v = vector_elt(v, 0);
i = GET_INT32(ip); ip+=4;
n = GET_INT32(ip); ip+=4;
s = GET_INT32(ip); ip+=4;
nargs = process_keys(v, i, n, abs(s)-(i+n), bp, nargs, s<0);
NEXT_OP;
#ifndef USE_COMPUTED_GOTO
default:
goto dispatch;
@ -1794,10 +1790,15 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len)
n = GET_INT32(ip); ip+=4;
sp += (n+2);
break;
case OP_LET: break;
case OP_OPTARGS:
i = abs(GET_INT32(ip)); ip+=4;
i = GET_INT32(ip); ip+=4;
n = abs(GET_INT32(ip)); ip+=4;
sp += (n-i);
break;
case OP_KEYARGS:
i = GET_INT32(ip); ip+=4;
n = GET_INT32(ip); ip+=4;
n = abs(GET_INT32(ip)); ip+=4;
sp += (n-i);
break;
case OP_BRBOUND:
@ -1854,7 +1855,7 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len)
case OP_LOADT: case OP_LOADF: case OP_LOADNIL: case OP_LOAD0:
case OP_LOAD1: case OP_LOADA0: case OP_LOADA1: case OP_LOADC00:
case OP_LOADC01: case OP_COPYENV: case OP_DUP:
case OP_LOADC01: case OP_DUP:
sp++;
break;

2
femtolisp/flisp.h
View File

@ -101,7 +101,7 @@ typedef struct _symbol_t {
#define iscbuiltin(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==builtintype))
void fl_gc_handle(value_t *pv);
void fl_free_gc_handles(int n);
void fl_free_gc_handles(uint32_t n);
#include "opcodes.h"

4
femtolisp/mkboot0.lsp
View File

@ -1,7 +1,7 @@
; -*- scheme -*-
;(if (not (bound? 'top-level-value)) (set! top-level-value %eval))
;(if (not (bound? 'set-top-level-value!)) (set! set-top-level-value! set))
(if (not (bound? 'top-level-value)) (set! top-level-value %eval))
(if (not (bound? 'set-top-level-value!)) (set! set-top-level-value! set))
;(load "compiler.lsp")

13
femtolisp/opcodes.h
View File

@ -23,11 +23,11 @@ enum {
OP_SETG, OP_SETGL,
OP_SETA, OP_SETAL, OP_SETC, OP_SETCL,
OP_CLOSURE, OP_ARGC, OP_VARGC, OP_TRYCATCH, OP_COPYENV, OP_LET, OP_FOR,
OP_CLOSURE, OP_ARGC, OP_VARGC, OP_TRYCATCH, 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_OPTARGS, OP_BRBOUND,
OP_OPTARGS, OP_BRBOUND, OP_KEYARGS,
OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
@ -37,7 +37,7 @@ enum {
#ifdef USE_COMPUTED_GOTO
#define VM_LABELS \
static void *vm_labels[] = { \
&&L_OP_NOP, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
&&L_OP_BRF, &&L_OP_BRT, \
&&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
\
@ -64,19 +64,18 @@ enum {
&&L_OP_SETA, &&L_OP_SETAL, &&L_OP_SETC, &&L_OP_SETCL, \
\
&&L_OP_CLOSURE, &&L_OP_ARGC, &&L_OP_VARGC, &&L_OP_TRYCATCH, \
&&L_OP_COPYENV, \
&&L_OP_LET, &&L_OP_FOR, \
&&L_OP_FOR, \
&&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_BRNE, &&L_OP_BRNEL, &&L_OP_CADR,\
&&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL, \
&&L_OP_OPTARGS, &&L_OP_BRBOUND \
&&L_OP_OPTARGS, &&L_OP_BRBOUND, &&L_OP_KEYARGS \
}
#define VM_APPLY_LABELS \
static void *vm_apply_labels[] = { \
&&L_OP_NOP, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
&&L_OP_BRF, &&L_OP_BRT, \
&&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
\

11
femtolisp/unittest.lsp
View File

@ -126,6 +126,17 @@
(assert (equal? ((lambda ((x 0) . r) (list x r))) '(0 ())))
(assert (equal? ((lambda ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
; keyword arguments
(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
'(1 0 0 (8 4 5))))
(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
'(0 2 3 (1))))
(define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d))
(assert (equal? (keys4 a: 10) '(10 3 7 6)))
(assert (equal? (keys4 b: 10) '(8 10 7 6)))
(assert (equal? (keys4 c: 10) '(8 3 10 6)))
(assert (equal? (keys4 d: 10) '(8 3 7 10)))
; ok, a couple end-to-end tests as well
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
(assert (equal? (fib 20) 6765))