From 1ad276252f3bf9e558907209e635dc72fadb51e7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 13 Mar 2009 22:56:43 +0900 Subject: [PATCH] fixing tail calls, now allowing variadic tail calls --- eval.c | 58 +++++++++++++++++++------------------- init.scm | 86 ++++++++++++++++++++++++++++++++++++++------------------ 2 files changed, 88 insertions(+), 56 deletions(-) diff --git a/eval.c b/eval.c index e4a94cc4..6de393be 100644 --- a/eval.c +++ b/eval.c @@ -373,7 +373,7 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, } emit_push(bc, i, op->data); emit(bc, i, op->op_name); - (*d) -= sexp_length(SEXP_CDR(obj)); + (*d) -= (sexp_length(SEXP_CDR(obj))-1); break; default: errx(1, "unknown opcode class: %d", op->op_class); @@ -425,8 +425,10 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, /* maybe overwrite the current frame */ if (tailp) { + fprintf(stderr, "compiling tail call: %d + %d + 3 = %d\n", + sexp_length(params), (*d), sexp_length(params)+(*d)+3); emit(bc, i, OP_TAIL_CALL); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_length(params)+(*d))); + emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_length(params)+(*d)+3)); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); } else { /* normal call */ @@ -613,7 +615,8 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { d--; } else { analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, - (! done_p) && (! SEXP_PAIRP(internals))); + (! done_p) && (! SEXP_PAIRP(internals)) + ); } } if (SEXP_PAIRP(internals)) { @@ -667,6 +670,11 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { tmp1 = env_cell(e, ((sexp*)ip)[0]); if (! tmp1) sexp_raise(sexp_intern("undefined-variable")); +/* fprintf(stderr, "global-ref: "); */ +/* sexp_write(((sexp*)ip)[0], cur_error_port); */ +/* fprintf(stderr, " => "); */ +/* sexp_write(SEXP_CDR(tmp1), cur_error_port); */ +/* fprintf(stderr, "\n"); */ stack[top++]=SEXP_CDR(tmp1); ip += sizeof(sexp); break; @@ -745,7 +753,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { ip += sizeof(sexp); break; case OP_PAIRP: - /* print_stack(stack, top); */ stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_NULLP: stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; @@ -832,36 +839,23 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_TAIL_CALL: + /* old-args ... n ret-ip ret-cp new-args ... proc */ + /* [================= j ===========================] */ + /* [==== i =====] */ j = sexp_unbox_integer(((sexp*)ip)[0]); /* current depth */ - ip += sizeof(sexp); - i = sexp_unbox_integer(((sexp*)ip)[0]); /* number of params */ + i = sexp_unbox_integer(((sexp*)ip)[1]); /* number of params */ tmp1 = stack[top-1]; /* procedure to call */ -/* fprintf(stderr, "tail call: depth=%d, i=%d, top=%d\n", j, i, top); */ -/* print_stack(stack, top); */ /* save frame info */ - stack[top] = stack[top-j-2]; - stack[top+1] = stack[top-j-1]; + ip = ((unsigned char*) sexp_unbox_integer(stack[top-i-3])) - sizeof(sexp); + cp = stack[top-i-2]; /* copy new args into place */ - for (k=top-i-1; kdata); */ - bc = sexp_procedure_code(tmp1); - ip = bc->data; - cp = sexp_procedure_vars(tmp1); - break; + for (k=0; k= INIT_STACK_SIZE) errx(1, "out of stack space: %d", top); - /* fprintf(stderr, "CALL\n"); */ - /* print_stack(stack, top); */ i = sexp_unbox_integer(((sexp*)ip)[0]); tmp1 = stack[top-1]; make_call: @@ -870,12 +864,18 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { tmp1 = make_opcode_procedure((opcode) tmp1, i, e); /* print_stack(stack, top); */ if (! SEXP_PROCEDUREP(tmp1)) { - fprintf(stderr, "error: non-procedure app\n"); + fprintf(stderr, "error: non-procedure app: "); + sexp_write(tmp1, cur_error_port); + fprintf(stderr, "\n"); sexp_raise(sexp_intern("non-procedure-application")); } j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); - if (j < 0) + if (j < 0) { + fprintf(stderr, "error: expected %d args but got %d\n", + sexp_unbox_integer(sexp_procedure_num_args(tmp1)), + i); sexp_raise(sexp_intern("not-enough-args")); + } if (j > 0) { if (sexp_procedure_variadic_p(tmp1)) { stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL); diff --git a/init.scm b/init.scm index e8c1a823..5521a917 100644 --- a/init.scm +++ b/init.scm @@ -6,31 +6,48 @@ (define (cdar x) (cdr (car x))) (define (cddr x) (cdr (cdr x))) -(define (caaar x) (car (car (car x)))) -(define (caadr x) (car (car (cdr x)))) -(define (cadar x) (car (cdr (car x)))) -(define (caddr x) (car (cdr (cdr x)))) -(define (cdaar x) (cdr (car (car x)))) -(define (cdadr x) (cdr (car (cdr x)))) -(define (cddar x) (cdr (cdr (car x)))) -(define (cdddr x) (cdr (cdr (cdr x)))) +;; (define (caaar x) (car (car (car x)))) +;; (define (caadr x) (car (car (cdr x)))) +;; (define (cadar x) (car (cdr (car x)))) +;; (define (caddr x) (car (cdr (cdr x)))) +;; (define (cdaar x) (cdr (car (car x)))) +;; (define (cdadr x) (cdr (car (cdr x)))) +;; (define (cddar x) (cdr (cdr (car x)))) +;; (define (cdddr x) (cdr (cdr (cdr x)))) -(define (caaaar x) (car (car (car (car x))))) -(define (caaadr x) (car (car (car (cdr x))))) -(define (caadar x) (car (car (cdr (car x))))) -(define (caaddr x) (car (car (cdr (cdr x))))) -(define (cadaar x) (car (cdr (car (car x))))) -(define (cadadr x) (car (cdr (car (cdr x))))) -(define (caddar x) (car (cdr (cdr (car x))))) -(define (cadddr x) (car (cdr (cdr (cdr x))))) -(define (cdaaar x) (cdr (car (car (car x))))) -(define (cdaadr x) (cdr (car (car (cdr x))))) -(define (cdadar x) (cdr (car (cdr (car x))))) -(define (cdaddr x) (cdr (car (cdr (cdr x))))) -(define (cddaar x) (cdr (cdr (car (car x))))) -(define (cddadr x) (cdr (cdr (car (cdr x))))) -(define (cdddar x) (cdr (cdr (cdr (car x))))) -(define (cddddr x) (cdr (cdr (cdr (cdr x))))) +;; (define (caaaar x) (car (car (car (car x))))) +;; (define (caaadr x) (car (car (car (cdr x))))) +;; (define (caadar x) (car (car (cdr (car x))))) +;; (define (caaddr x) (car (car (cdr (cdr x))))) +;; (define (cadaar x) (car (cdr (car (car x))))) +;; (define (cadadr x) (car (cdr (car (cdr x))))) +;; (define (caddar x) (car (cdr (cdr (car x))))) +;; (define (cadddr x) (car (cdr (cdr (cdr x))))) +;; (define (cdaaar x) (cdr (car (car (car x))))) +;; (define (cdaadr x) (cdr (car (car (cdr x))))) +;; (define (cdadar x) (cdr (car (cdr (car x))))) +;; (define (cdaddr x) (cdr (car (cdr (cdr x))))) +;; (define (cddaar x) (cdr (cdr (car (car x))))) +;; (define (cddadr x) (cdr (cdr (car (cdr x))))) +;; (define (cdddar x) (cdr (cdr (cdr (car x))))) +;; (define (cddddr x) (cdr (cdr (cdr (cdr x))))) + +(define (list . args) args) + +(define (append-reverse a b) + (if (pair? a) + (append-reverse (cdr a) (cons (car a) b)) + b)) + +(define (append a b) + (append-reverse (reverse a) b)) + +(define (apply proc . args) + (if (null? args) + (proc) + ((lambda (lol) + (apply1 proc (append (reverse (cdr lol)) (car lol)))) + (reverse args)))) ;; map with a fast-path for single lists @@ -40,8 +57,6 @@ (mapn proc (cons ls lol) '()))) (define (map1 proc ls res) -;; (write ls) -;; (newline) (if (pair? ls) (map1 proc (cdr ls) (cons (proc (car ls)) res)) (reverse res))) @@ -49,5 +64,22 @@ (define (mapn proc lol res) (if (null? lol) (reverse res) - (mapn proc (cdr lol) (cons (apply proc (map1 car lol)) res)))) + (mapn proc (cdr lol) (cons (apply1 proc (map1 car lol '())) res)))) +;; syntax + +(define-syntax let + (lambda (expr use-env mac-env) + (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) + (map cadr (cadr expr))))) + +(define-syntax or + (lambda (expr use-env mac-env) + (if (null? (cdr expr)) + #f + (if (null? (cddr expr)) + (cadr expr) + (list 'let (list (list 'tmp (cadr expr))) + (list 'if 'tmp + 'tmp + (cons 'or (cddr expr))))))))