ref: 0278b152b887c495dbd4d9c4feb75e384cd996e2
parent: 57c066fcdfd6058cf51154ae00e24d6a74f3a192
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Mon Jul 20 23:42:15 EDT 2009
fixing a case where tail position was not properly observed
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -808,11 +808,9 @@
#ifdef USE_COMPUTED_GOTO
#define OP(x) L_##x:
#define NEXT_OP goto *vm_labels[*ip++]
-#define DISPATCH goto *vm_labels[op]
#else
#define OP(x) case x:
#define NEXT_OP goto next_op
-#define DISPATCH goto dispatch
#endif
/*
@@ -831,6 +829,7 @@
static value_t apply_cl(uint32_t nargs)
{VM_LABELS;
+ VM_APPLY_LABELS;
uint32_t top_frame = curr_frame;
// frame variables
uint32_t n, captured;
@@ -839,7 +838,9 @@
fixnum_t s, hi;
// temporary variables (not necessary to preserve across calls)
+#ifndef USE_COMPUTED_GOTO
uint32_t op;
+#endif
uint32_t i;
symbol_t *sym;
static cons_t *c;
@@ -877,6 +878,7 @@
#endif
OP(OP_ARGC)
n = *ip++;
+ do_argc:
if (nargs != n) {if (nargs > n)
lerror(ArgError, "apply: too many arguments");
@@ -916,13 +918,7 @@
NEXT_OP;
OP(OP_LARGC)
n = GET_INT32(ip); ip+=4;
- if (nargs != n) {- if (nargs > n)
- lerror(ArgError, "apply: too many arguments");
- else
- lerror(ArgError, "apply: too few arguments");
- }
- NEXT_OP;
+ goto do_argc;
OP(OP_LVARGC)
i = GET_INT32(ip); ip+=4;
goto do_vargc;
@@ -941,20 +937,62 @@
OP(OP_TCALL)
n = *ip++; // nargs
do_tcall:
- if (isfunction(Stack[SP-n-1])) {- curr_frame = Stack[curr_frame-4];
- for(s=-1; s < (fixnum_t)n; s++)
- Stack[bp+s] = Stack[SP-n+s];
- SP = bp+n;
- nargs = n;
- goto apply_cl_top;
+ func = Stack[SP-n-1];
+ if (tag(func) == TAG_FUNCTION) {+ if (func > (N_BUILTINS<<3)) {+ curr_frame = Stack[curr_frame-4];
+ for(s=-1; s < (fixnum_t)n; s++)
+ Stack[bp+s] = Stack[SP-n+s];
+ SP = bp+n;
+ nargs = n;
+ goto apply_cl_top;
+ }
+ else {+ i = uintval(func);
+ if (i <= OP_ASET) {+ s = builtin_arg_counts[i];
+ if (s >= 0)
+ argcount(builtin_names[i], n, s);
+ else if (s != ANYARGS && (signed)n < -s)
+ argcount(builtin_names[i], n, -s);
+ // remove function arg
+ for(s=SP-n-1; s < (int)SP-1; s++)
+ Stack[s] = Stack[s+1];
+ SP--;
+#ifdef USE_COMPUTED_GOTO
+ if (i == OP_APPLY)
+ goto apply_tapply;
+ goto *vm_apply_labels[i];
+#else
+ switch (i) {+ case OP_LIST: goto apply_list;
+ case OP_VECTOR: goto apply_vector;
+ case OP_APPLY: goto apply_tapply;
+ case OP_ADD: goto apply_add;
+ case OP_SUB: goto apply_sub;
+ case OP_MUL: goto apply_mul;
+ case OP_DIV: goto apply_div;
+ default:
+ op = (uint8_t)i;
+ goto dispatch;
+ }
+#endif
+ }
+ }
}
- goto do_call;
+ else if (iscbuiltin(func)) {+ s = SP;
+ v = (((builtin_t*)ptr(func))[3])(&Stack[SP-n], n);
+ SP = s-n;
+ Stack[SP-1] = v;
+ NEXT_OP;
+ }
+ type_error("apply", "function", func);+ // WARNING: repeated code ahead
OP(OP_CALL)
n = *ip++; // nargs
do_call:
func = Stack[SP-n-1];
- s = SP;
if (tag(func) == TAG_FUNCTION) { if (func > (N_BUILTINS<<3)) {Stack[curr_frame-2] = (uptrint_t)ip;
@@ -963,40 +1001,43 @@
}
else {i = uintval(func);
- if (i > OP_ASET)
- type_error("apply", "function", func);- op = (uint8_t)i;
- s = builtin_arg_counts[op];
- if (s >= 0)
- argcount(builtin_names[op], n, s);
- else if (s != ANYARGS && (signed)n < -s)
- argcount(builtin_names[op], n, -s);
- // remove function arg
- for(s=SP-n-1; s < (int)SP-1; s++)
- Stack[s] = Stack[s+1];
- SP--;
- switch (op) {- case OP_LIST: goto apply_list;
- case OP_VECTOR: goto apply_vector;
- case OP_APPLY: goto apply_apply;
- case OP_ADD: goto apply_add;
- case OP_SUB: goto apply_sub;
- case OP_MUL: goto apply_mul;
- case OP_DIV: goto apply_div;
- default:
- DISPATCH;
+ if (i <= OP_ASET) {+ s = builtin_arg_counts[i];
+ if (s >= 0)
+ argcount(builtin_names[i], n, s);
+ else if (s != ANYARGS && (signed)n < -s)
+ argcount(builtin_names[i], n, -s);
+ // remove function arg
+ for(s=SP-n-1; s < (int)SP-1; s++)
+ Stack[s] = Stack[s+1];
+ SP--;
+#ifdef USE_COMPUTED_GOTO
+ goto *vm_apply_labels[i];
+#else
+ switch (i) {+ case OP_LIST: goto apply_list;
+ case OP_VECTOR: goto apply_vector;
+ case OP_APPLY: goto apply_apply;
+ case OP_ADD: goto apply_add;
+ case OP_SUB: goto apply_sub;
+ case OP_MUL: goto apply_mul;
+ case OP_DIV: goto apply_div;
+ default:
+ op = (uint8_t)i;
+ goto dispatch;
+ }
+#endif
}
}
}
else if (iscbuiltin(func)) {+ s = SP;
v = (((builtin_t*)ptr(func))[3])(&Stack[SP-n], n);
+ SP = s-n;
+ Stack[SP-1] = v;
+ NEXT_OP;
}
- else {- type_error("apply", "function", func);- }
- SP = s-n;
- Stack[SP-1] = v;
- NEXT_OP;
+ type_error("apply", "function", func);OP(OP_JMP) ip += (ptrint_t)GET_INT16(ip); NEXT_OP;
OP(OP_BRF)
v = POP();
@@ -1129,10 +1170,19 @@
NEXT_OP;
OP(OP_TAPPLY)
+ n = *ip++;
+ apply_tapply:
+ v = POP(); // arglist
+ n = SP-(n-2); // n-2 == # leading arguments not in the list
+ while (iscons(v)) {+ if (SP >= N_STACK)
+ grow_stack();
+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ n = SP-n;
+ goto do_tcall;
OP(OP_APPLY)
-#ifdef USE_COMPUTED_GOTO
- op = ip[-1];
-#endif
n = *ip++;
apply_apply:
v = POP(); // arglist
@@ -1144,8 +1194,7 @@
v = cdr_(v);
}
n = SP-n;
- if (op==OP_TAPPLY) goto do_tcall;
- else goto do_call;
+ goto do_call;
OP(OP_ADD)
n = *ip++;
@@ -1594,12 +1643,10 @@
break;
case OP_LARGC:
n = GET_INT32(ip); ip+=4;
- sp += (n+2);
break;
case OP_LVARGC:
- // move extra arguments from list to stack
n = GET_INT32(ip); ip+=4;
- sp += (n+3);
+ sp += (n+2);
break;
case OP_LET: break;
--- a/femtolisp/opcodes.h
+++ b/femtolisp/opcodes.h
@@ -68,8 +68,30 @@
&&L_OP_LVARGC, \
&&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01 \
}
+
+#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, \
+ &&L_OP_BRF, &&L_OP_BRT, \
+ &&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
+ \
+ &&L_OP_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, &&L_OP_NOT, \
+ &&L_OP_NULLP, &&L_OP_BOOLEANP, \
+ &&L_OP_SYMBOLP, &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, \
+ &&L_OP_BUILTINP, &&L_OP_VECTORP, \
+ &&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
+ \
+ &&L_OP_CONS, &&apply_list, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_SETCAR, \
+ &&L_OP_SETCDR, &&apply_apply, \
+ \
+ &&apply_add, &&apply_sub, &&apply_mul, &&apply_div, &&L_OP_IDIV, &&L_OP_NUMEQ, \
+ &&L_OP_LT, &&L_OP_COMPARE, \
+ \
+ &&apply_vector, &&L_OP_AREF, &&L_OP_ASET \
+ }
#else
#define VM_LABELS
+#define VM_APPLY_LABELS
#endif
#endif
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -1040,7 +1040,6 @@
. largs instruction to move args after MAX_ARGS from list to stack
* maxstack calculation, make Stack growable
* stack traces and better debugging support
- - make maxstack calculation robust against invalid bytecode
* improve internal define
* try removing MAX_ARGS trickery
- apply optimization, avoid redundant list copying calling vararg fns