Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 14:49:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

trimming opcodes

Browse source
This commit is contained in:
Alex Shinn 2009-03-31 20:18:10 +09:00
parent eaf79f4856
commit b599eab54d
4 changed files with 65 additions and 60 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
debug.c
View file

@ -7,8 +7,8 @@ static const char* reverse_opcode_names[] =
"FCALL0", "FCALL1", "FCALL2", "FCALL3", "EVAL", "JUMP_UNLESS", "JUMP", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "EVAL", "JUMP_UNLESS", "JUMP",
"PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET", "PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET",
"CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET",
"MAKE_PROCEDURE", "MAKE_VECTOR", "PAIRP", "NULLP", "VECTORP", "INTEGERP", "MAKE_PROCEDURE", "MAKE_VECTOR", "NULLP", "INTEGERP",
"SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", "OPORTP", "SYMBOLP", "CHARP", "EOFP", "TYPEP",
"CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", "DIV",
"QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", "DISPLAY", "WRITE", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", "DISPLAY", "WRITE",
"WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ", "READ_CHAR", "RET", "DONE", "WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ", "READ_CHAR", "RET", "DONE",
@ -30,6 +30,11 @@ void disasm (sexp bc) {
case OP_CLOSURE_REF: case OP_CLOSURE_REF:
case OP_JUMP: case OP_JUMP:
case OP_JUMP_UNLESS: case OP_JUMP_UNLESS:
case OP_FCALL0:
case OP_FCALL1:
case OP_FCALL2:
case OP_FCALL3:
case OP_TYPEP:
fprintf(stderr, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); fprintf(stderr, "%ld", (sexp_sint_t) ((sexp*)ip)[0]);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;

107
eval.c
View file

@ -662,20 +662,23 @@ static void generate_opcode_app (sexp app, sexp context) {
generate(sexp_car(ls), context); generate(sexp_car(ls), context);
/* emit the actual operator call */ /* emit the actual operator call */
if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { switch (sexp_opcode_class(op)) {
case OPC_ARITHMETIC_INV:
emit((num_args == 1) ? sexp_opcode_inverse(op) emit((num_args == 1) ? sexp_opcode_inverse(op)
: sexp_opcode_code(op), context); : sexp_opcode_code(op), context);
} else { break;
if (sexp_opcode_class(op) == OPC_FOREIGN) { case OPC_FOREIGN:
/* push the funtion pointer for foreign calls */ case OPC_TYPE_PREDICATE:
emit_push(sexp_opcode_data(op), context); /* push the funtion pointer for foreign calls */
emit(sexp_opcode_code(op), context); emit(sexp_opcode_code(op), context);
} else if (sexp_opcode_class(op) == OPC_PARAMETER) { if (sexp_opcode_data(op))
emit_push(sexp_opcode_data(op), context); emit_word((sexp_uint_t)sexp_opcode_data(op), context);
emit(OP_CDR, context); break;
} else { case OPC_PARAMETER:
emit(sexp_opcode_code(op), context); emit_push(sexp_opcode_data(op), context);
} emit(OP_CDR, context);
default:
emit(sexp_opcode_code(op), context);
} }
/* emit optional folding of operator */ /* emit optional folding of operator */
@ -887,9 +890,14 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) {
#define _ARG4 stack[top-4] #define _ARG4 stack[top-4]
#define _ARG5 stack[top-5] #define _ARG5 stack[top-5]
#define _PUSH(x) (stack[top++]=(x)) #define _PUSH(x) (stack[top++]=(x))
#define _POP() (stack[--top]) #define _WORD0 ((sexp*)ip)[0]
#define _UWORD0 ((sexp_uint_t*)ip)[0]
#define _SWORD0 ((sexp_sint_t*)ip)[0]
#define sexp_raise(msg, args) do {stack[top]=sexp_compile_error(msg, args); top++; goto call_error_handler;} while (0) #define sexp_raise(msg, args) do {stack[top]=sexp_compile_error(msg, args); \
top++; \
goto call_error_handler;} \
while (0)
sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
unsigned char *ip=sexp_bytecode_data(bc); unsigned char *ip=sexp_bytecode_data(bc);
@ -952,7 +960,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
ip -= sizeof(sexp); ip -= sizeof(sexp);
goto make_call; goto make_call;
case OP_TAIL_CALL: case OP_TAIL_CALL:
i = sexp_unbox_integer(((sexp*)ip)[0]); /* number of params */ i = sexp_unbox_integer(_WORD0); /* number of params */
tmp1 = _ARG1; /* procedure to call */ tmp1 = _ARG1; /* procedure to call */
/* save frame info */ /* save frame info */
j = sexp_unbox_integer(stack[fp]); j = sexp_unbox_integer(stack[fp]);
@ -967,7 +975,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
case OP_CALL: case OP_CALL:
if (top >= INIT_STACK_SIZE) if (top >= INIT_STACK_SIZE)
sexp_raise("out of stack space", SEXP_NULL); sexp_raise("out of stack space", SEXP_NULL);
i = sexp_unbox_integer(((sexp*)ip)[0]); i = sexp_unbox_integer(_WORD0);
tmp1 = _ARG1; tmp1 = _ARG1;
make_call: make_call:
if (sexp_opcodep(tmp1)) { if (sexp_opcodep(tmp1)) {
@ -1014,57 +1022,60 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
fp = top-4; fp = top-4;
break; break;
case OP_FCALL0: case OP_FCALL0:
_ARG1 = ((sexp_proc0)_ARG1)(); _PUSH(((sexp_proc0)_UWORD0)());
ip += sizeof(sexp);
if (sexp_exceptionp(_ARG1)) goto call_error_handler; if (sexp_exceptionp(_ARG1)) goto call_error_handler;
break; break;
case OP_FCALL1: case OP_FCALL1:
_ARG2 = ((sexp_proc1)_ARG1)(_ARG2); _ARG1 = ((sexp_proc1)_UWORD0)(_ARG1);
top--; ip += sizeof(sexp);
if (sexp_exceptionp(_ARG1)) goto call_error_handler; if (sexp_exceptionp(_ARG1)) goto call_error_handler;
break; break;
case OP_FCALL2: case OP_FCALL2:
_ARG3 = ((sexp_proc2)_ARG1)(_ARG2, _ARG3); _ARG2 = ((sexp_proc2)_UWORD0)(_ARG1, _ARG2);
top-=2; top--;
ip += sizeof(sexp);
if (sexp_exceptionp(_ARG1)) goto call_error_handler; if (sexp_exceptionp(_ARG1)) goto call_error_handler;
break; break;
case OP_FCALL3: case OP_FCALL3:
_ARG4 =((sexp_proc3)_ARG1)(_ARG2, _ARG3, _ARG4); _ARG3 =((sexp_proc3)_UWORD0)(_ARG1, _ARG2, _ARG3);
top-=3; top-=2;
ip += sizeof(sexp);
if (sexp_exceptionp(_ARG1)) goto call_error_handler; if (sexp_exceptionp(_ARG1)) goto call_error_handler;
break; break;
case OP_JUMP_UNLESS: case OP_JUMP_UNLESS:
if (stack[--top] == SEXP_FALSE) if (stack[--top] == SEXP_FALSE)
ip += ((sexp_sint_t*)ip)[0]; ip += _SWORD0;
else else
ip += sizeof(sexp_sint_t); ip += sizeof(sexp_sint_t);
break; break;
case OP_JUMP: case OP_JUMP:
ip += ((sexp_sint_t*)ip)[0]; ip += _SWORD0;
break; break;
case OP_PUSH: case OP_PUSH:
_PUSH(((sexp*)ip)[0]); _PUSH(_WORD0);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_DROP: case OP_DROP:
top--; top--;
break; break;
case OP_STACK_REF: /* `pick' in forth */ case OP_STACK_REF: /* `pick' in forth */
stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; stack[top] = stack[top - _SWORD0];
ip += sizeof(sexp); ip += sizeof(sexp);
top++; top++;
break; break;
case OP_LOCAL_REF: case OP_LOCAL_REF:
stack[top] = stack[fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]]; stack[top] = stack[fp - 1 - _SWORD0];
ip += sizeof(sexp); ip += sizeof(sexp);
top++; top++;
break; break;
case OP_LOCAL_SET: case OP_LOCAL_SET:
stack[fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; stack[fp - 1 - _SWORD0] = _ARG1;
_ARG1 = SEXP_UNDEF; _ARG1 = SEXP_UNDEF;
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_CLOSURE_REF: case OP_CLOSURE_REF:
_PUSH(sexp_vector_ref(cp, sexp_make_integer(((sexp*)ip)[0]))); _PUSH(sexp_vector_ref(cp, sexp_make_integer(_WORD0)));
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_VECTOR_REF: case OP_VECTOR_REF:
@ -1097,28 +1108,22 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
_ARG2 = sexp_make_vector(_ARG1, _ARG2); _ARG2 = sexp_make_vector(_ARG1, _ARG2);
top--; top--;
break; break;
case OP_PAIRP: case OP_EOFP:
_ARG1 = sexp_make_boolean(sexp_pairp(_ARG1)); break; _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break;
case OP_NULLP: case OP_NULLP:
_ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break;
case OP_VECTORP:
_ARG1 = sexp_make_boolean(sexp_vectorp(_ARG1)); break;
case OP_INTEGERP: case OP_INTEGERP:
_ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break; _ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break;
case OP_SYMBOLP: case OP_SYMBOLP:
_ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break;
case OP_STRINGP:
_ARG1 = sexp_make_boolean(sexp_stringp(_ARG1)); break;
case OP_CHARP: case OP_CHARP:
_ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break;
case OP_EOFP: case OP_TYPEP:
_ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; _ARG1 = sexp_make_boolean(sexp_pointerp(_ARG1)
case OP_PROCEDUREP: && (sexp_pointer_tag(_ARG1)
_ARG1 = sexp_make_boolean(sexp_procedurep(_ARG1)); break; == _UWORD0));
case OP_IPORTP: ip += sizeof(sexp);
_ARG1 = sexp_make_boolean(sexp_iportp(_ARG1)); break; break;
case OP_OPORTP:
_ARG1 = sexp_make_boolean(sexp_oportp(_ARG1)); break;
case OP_CAR: case OP_CAR:
if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(_ARG1)); if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(_ARG1));
_ARG1 = sexp_car(_ARG1); break; _ARG1 = sexp_car(_ARG1); break;
@ -1404,16 +1409,16 @@ _OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL),
_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL), _OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL),
_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL), _OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL),
_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", NULL, NULL), _OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, 0, "pair?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, 0, "string?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_VECTORP, 1, 0, 0, 0, 0, "vector?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", (sexp)SEXP_PAIR, NULL),
_OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, 0, "procedure?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", (sexp)SEXP_STRING, NULL),
_OP(OPC_TYPE_PREDICATE, OP_IPORTP, 1, 0, 0, 0, 0, "input-port?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", (sexp)SEXP_VECTOR, NULL),
_OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", (sexp)SEXP_PROCEDURE, NULL),
_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", (sexp)SEXP_IPORT, NULL),
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", (sexp)SEXP_OPORT, NULL),
_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL), _OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL),
_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL), _OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL),
_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL), _OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL),

7
eval.h
View file

@ -83,17 +83,12 @@ enum opcode_names {
OP_STRING_SET, OP_STRING_SET,
OP_MAKE_PROCEDURE, OP_MAKE_PROCEDURE,
OP_MAKE_VECTOR, OP_MAKE_VECTOR,
OP_PAIRP,
OP_NULLP, OP_NULLP,
OP_VECTORP,
OP_INTEGERP, OP_INTEGERP,
OP_SYMBOLP, OP_SYMBOLP,
OP_STRINGP,
OP_CHARP, OP_CHARP,
OP_EOFP, OP_EOFP,
OP_PROCEDUREP, OP_TYPEP,
OP_IPORTP,
OP_OPORTP,
OP_CAR, OP_CAR,
OP_CDR, OP_CDR,
OP_SET_CAR, OP_SET_CAR,

2
init.scm
View file

@ -1,6 +1,6 @@
;; let* cond case delay and do ;; let* cond case delay and do
;; quasiquote unquote unquote-splicing let-syntax ;; quasiquote let-syntax
;; letrec-syntax syntax-rules eqv? equal? not boolean? number? ;; letrec-syntax syntax-rules eqv? equal? not boolean? number?
;; complex? real? rational? integer? exact? inexact? ;; complex? real? rational? integer? exact? inexact?
;; positive? negative? odd? even? max min quotient remainder ;; positive? negative? odd? even? max min quotient remainder