From cd6d1e61ef3701ecd21b54e5918e3de05bf31e21 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sun, 13 Oct 2002 16:57:24 +0000 Subject: [PATCH] Simplify the bytecodes a bit and add comments describing their use. --- src/c/compiler.d | 21 +- src/c/disassembler.d | 495 ++++++++++++++++++++++++++++++++++--------- src/c/interpreter.d | 473 +++++++++++++++++++++++++++++++++-------- src/h/bytecodes.h | 17 +- src/h/stacks.h | 23 +- 5 files changed, 806 insertions(+), 223 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 9d4b80a05..0d01a3ec4 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -403,8 +403,9 @@ c_tag_ref(cl_object the_tag, cl_object the_type) return Ct; n++; } else if (Null(name)) { - /* We are counting only locals */ n++; + } else { + /* We are counting only locals and ignore specials */ } } return Cnil; @@ -525,9 +526,10 @@ compile_setq(int op, cl_object var) if (!SYMBOLP(var)) FEillegal_variable_name(var); ndx = c_var_ref(var); - if (ndx >= 0) + if (ndx >= 0) { asm_op2(op, ndx); /* Lexical variable */ - else if (var->symbol.stype == stp_constant) + return; + } else if (var->symbol.stype == stp_constant) FEassignment_to_constant(var); else if (op == OP_SETQ) asm_op(OP_SETQS); /* Special variable */ @@ -1325,16 +1327,17 @@ c_multiple_value_bind(cl_object args) c_env.variables = old_env; } else { cl_object old_variables = c_env.variables; - asm_op2(OP_MBIND, n); for (vars=reverse(vars); n; n--){ cl_object var = pop(&vars); if (!SYMBOLP(var)) FEillegal_variable_name(var); if (c_declared_special(var, specials)) { - asm1(MAKE_FIXNUM(1)); c_register_var(var, TRUE); - } else + asm_op2(OP_VBINDS, n); + } else { c_register_var(var, FALSE); + asm_op2(OP_VBIND, n); + } asm1(var); } compile_body(body); @@ -1428,11 +1431,10 @@ c_multiple_value_setq(cl_object args) { FEillegal_variable_name(var); ndx = c_var_ref(var); if (ndx >= 0) - asm1(var); /* Lexical variable */ + asm1(MAKE_FIXNUM(ndx)); /* Lexical variable */ else if (var->symbol.stype == stp_constant) FEassignment_to_constant(var); else { - asm1(MAKE_FIXNUM(1)); asm1(var); } } @@ -1805,10 +1807,11 @@ compile_form(cl_object stmt, bool push) { index = c_var_ref(stmt); if (index >= 0) { asm_op2(push? OP_PUSHV : OP_VAR, index); + asm1(stmt); } else { asm_op(push? OP_PUSHVS : OP_VARS); + asm1(stmt); } - asm1(stmt); goto OUTPUT; } QUOTED: diff --git a/src/c/disassembler.d b/src/c/disassembler.d index a4078f2f2..e4a25e8b3 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -109,29 +109,55 @@ search_symbol(register cl_object s) { /* -------------------- DISASSEMBLER CORE -------------------- */ +/* OP_BLOCK label{arg}, block-name{symbol} + ... + OP_EXIT + label: + + Executes the enclosed code in a named block. + LABEL points to the first instruction after OP_EXIT. +*/ static cl_object * disassemble_block(cl_object *vector) { cl_object lex_old = lex_env; cl_fixnum exit = packed_label(vector-1); + cl_object block_name = next_code(vector); + + lex_env = listX(3, @':block', CONS(block_name, Cnil), lex_env); printf("BLOCK\t"); - @prin1(1, next_code(vector)); + @prin1(1, block_name); printf(",%d", exit); vector = disassemble(vector); - printf("\t\t\t; block"); + printf("\t\t; block"); lex_env = lex_old; return vector; } +/* OP_CATCH label{arg} + ... + OP_EXIT + label: + + Sets a catch point using the tag in VALUES(0). LABEL points + to the first instruction after the end (OP_EXIT) of the block +*/ static cl_object * disassemble_catch(cl_object *vector) { printf("CATCH\t%d", packed_label(vector - 1)); vector = disassemble(vector); - printf("\t\t\t; catch"); + printf("\t\t; catch"); return vector; } +/* OP_DO label + ... ; code executed within a NIL block + OP_EXIT + label: + + High level construct for the DO and BLOCK forms. +*/ static cl_object * disassemble_do(cl_object *vector) { cl_fixnum exit; @@ -141,12 +167,24 @@ disassemble_do(cl_object *vector) { exit = packed_label(vector-1); printf("DO\t%d", exit); vector = disassemble(vector); - printf("\t\t\t; do"); + printf("\t\t; do"); lex_env = lex_old; return vector; } +/* OP_DOLIST label + ... ; code to bind the local variable + OP_EXIT + ... ; code executed on each iteration + OP_EXIT + ... ; code executed at the end + OP_EXIT + label: + + High level construct for the DOLIST iterator. The list over which + we iterate is stored in VALUES(0). +*/ static cl_object * disassemble_dolist(cl_object *vector) { cl_fixnum exit; @@ -156,16 +194,28 @@ disassemble_dolist(cl_object *vector) { exit = packed_label(vector-1); printf("DOLIST\t%d", exit); vector = disassemble(vector); - printf("\t\t\t; dolist binding"); + printf("\t\t; dolist binding"); vector = disassemble(vector); - printf("\t\t\t; dolist body"); + printf("\t\t; dolist body"); vector = disassemble(vector); - printf("\t\t\t; dolist"); + printf("\t\t; dolist"); lex_env = lex_old; return vector; } +/* OP_TIMES label + ... ; code to bind the local variable + OP_EXIT + ... ; code executed on each iteration + OP_EXIT + ... ; code executed at the end + OP_EXIT + label: + + High level construct for the DOTIMES iterator. The number of times + we iterate is stored in VALUES(0). +*/ static cl_object * disassemble_dotimes(cl_object *vector) { cl_fixnum exit; @@ -175,16 +225,26 @@ disassemble_dotimes(cl_object *vector) { exit = packed_label(vector-1); printf("DOTIMES\t%d", exit); vector = disassemble(vector); - printf("\t\t\t; dotimes times"); + printf("\t\t; dotimes times"); vector = disassemble(vector); - printf("\t\t\t; dotimes body"); + printf("\t\t; dotimes body"); vector = disassemble(vector); - printf("\t\t\t; dotimes"); + printf("\t\t; dotimes"); lex_env = lex_old; return vector; } +/* OP_FLET nfun{arg} + fun1{object} + ... + funn{object} + ... + OP_EXIT + + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". +*/ static cl_object * disassemble_flet(cl_object *vector) { cl_object lex_old = lex_env; @@ -199,12 +259,22 @@ disassemble_flet(cl_object *vector) { @prin1(1, fun->bytecodes.data[0]); } vector = disassemble(vector); - printf("\t\t\t; flet"); + printf("\t\t; flet"); lex_env = lex_old; return vector; } +/* OP_LABELS nfun{arg} + fun1{object} + ... + funn{object} + ... + OP_EXIT + + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". +*/ static cl_object * disassemble_labels(cl_object *vector) { cl_object lex_old = lex_env; @@ -219,45 +289,52 @@ disassemble_labels(cl_object *vector) { @prin1(1, fun->bytecodes.data[0]); } vector = disassemble(vector); - printf("\t\t\t; labels"); + printf("\t\t; labels"); lex_env = lex_old; return vector; } +/* OP_MCALL + ... + OP_EXIT + + Saves the stack pointer, executes the enclosed code and + funcalls VALUE(0) using the content of the stack. +*/ static cl_object * -disassemble_mbind(cl_object *vector) -{ - int i = get_oparg(vector[-1]); - bool newline = FALSE; - while (i--) { - cl_object var = next_code(vector); - if (newline) { - @terpri(0); - printf("\t"); - } else - newline = TRUE; - if (var == MAKE_FIXNUM(1)) { - printf("MBINDS\t"); - var = next_code(vector); - } else { - printf("MBIND\t"); - } - @prin1(1, var); - printf(", VALUES(%d)", i); - } +disassemble_mcall(cl_object *vector) { + printf("MCALL"); + vector = disassemble(vector); + printf("\t\t; mcall"); return vector; } +/* OP_PROG1 + ... + OP_EXIT + + Save the values in VALUES(..), execute the code enclosed, and + restore the values. +*/ static cl_object * disassemble_mprog1(cl_object *vector) { printf("MPROG1"); vector = disassemble(vector); - printf("\t\t\t; mprog1"); + printf("\t\t; mprog1"); return vector; } +/* OP_MSETQ n{arg} + {fixnumn}|{symboln} + ... + {fixnum1}|{symbol1} + Sets N variables to the N values in VALUES(), filling with + NIL when there are values missing. Local variables are denoted + with an integer which points a position in the lexical environment, + while special variables are denoted just with the name. +*/ static cl_object * disassemble_msetq(cl_object *vector) { @@ -270,36 +347,46 @@ disassemble_msetq(cl_object *vector) printf("\t"); } else newline = TRUE; - if (var == MAKE_FIXNUM(1)) { - printf("MSETQS\t"); - var = next_code(vector); + if (FIXNUMP(var)) { + printf("MSETQ\t%d", fix(var)); } else { - printf("MSETQ\t"); + printf("MSETQS\t"); + @prin1(1, var); } - @prin1(1, var); printf(", VALUES(%d)", i); } return vector; } +/* OP_PROGV bindings{list} + ... + OP_EXIT + Execute the code enclosed with the special variables in BINDINGS + set to the values in the list which was passed in VALUES(0). +*/ static cl_object * disassemble_progv(cl_object *vector) { printf("PROGV"); vector = disassemble(vector); - printf("\t\t\t; progv"); + printf("\t\t; progv"); return vector; } -/* OP_TAGBODY n-tags - tag1 addr1 - tag2 addr2 - ... ... - tagn addrn - {form}* - OP_EXIT -*/ +/* OP_TAGBODY n{arg} + tag1 + label1 + ... + tagn + labeln +label1: + ... +labeln: + ... + OP_EXIT + High level construct for the TAGBODY form. +*/ static cl_object * disassemble_tagbody(cl_object *vector) { cl_index i, ntags = get_oparg(vector[-1]); @@ -313,12 +400,24 @@ disassemble_tagbody(cl_object *vector) { printf(" @@ %d", simple_label(vector)); } vector = disassemble(vector); - printf("\t\t\t; tagbody"); + printf("\t\t; tagbody"); lex_env = lex_old; return vector; } +/* OP_UNWIND label + ... ; code to be protected and whose value is output + OP_EXIT +label: + ... ; code executed at exit + OP_EXIT + High level construct for UNWIND-PROTECT. The first piece of code + is executed and its output value is saved. Then the second piece + of code is executed and the output values restored. The second + piece of code is always executed, even if a THROW, RETURN or GO + happen within the first piece of code. +*/ static cl_object * disassemble_unwind_protect(cl_object *vector) { cl_fixnum exit = packed_label(vector-1); @@ -326,7 +425,7 @@ disassemble_unwind_protect(cl_object *vector) { printf("PROTECT\t%d", exit); vector = disassemble(vector); vector = disassemble(vector); - printf("\t\t\t; protect"); + printf("\t\t; protect"); return vector; } @@ -352,106 +451,302 @@ disassemble(cl_object *vector) { goto BEGIN; } switch (GET_OP(s)) { - case OP_PUSHQ: printf("PUSH\t'"); - @prin1(1,next_code(vector)); - break; - case OP_PUSH: string = "PUSH\tVALUES(0)"; goto NOARG; - case OP_PUSHV: string = "PUSHV"; goto SETQ; - case OP_PUSHVS: string = "PUSHVS"; goto QUOTE; - case OP_VAR: string = "VAR"; goto SETQ; - case OP_VARS: string = "VARS"; goto QUOTE; - case OP_QUOTE: string = "QUOTE"; - QUOTE: s = next_code(vector); - goto ARG; + + /* OP_NOP + Sets VALUES(0) = NIL and NValues = 1 + */ case OP_NOP: string = "NOP"; goto NOARG; + + /* OP_QUOTE + Sets VALUES(0) to an immediate value. + */ + case OP_QUOTE: string = "QUOTE\t"; + s = next_code(vector); + goto ARG; + + /* OP_VAR n{arg}, var{symbol} + Sets NValues=1 and VALUES(0) to the value of the n-th local. + VAR is the name of the variable for readability purposes. + */ + case OP_VAR: string = "VAR\t"; + n = get_oparg(s); + s = next_code(vector); + goto OPARG_ARG; + + /* OP_VARS var{symbol} + Sets NValues=1 and VALUES(0) to the value of the symbol VAR. + VAR should be either a special variable or a constant. + */ + case OP_VARS: string = "VARS\t"; + s = next_code(vector); + goto ARG; + + /* OP_PUSH + Pushes the object in VALUES(0). + */ + case OP_PUSH: string = "PUSH\tVALUES(0)"; + goto NOARG; + + /* OP_PUSHV n{arg}, var{symbol} + Pushes the value of the n-th local onto the stack. + VAR is the name of the variable for readability purposes. + */ + case OP_PUSHV: string = "PUSHV\t"; + n = get_oparg(s); + s = next_code(vector); + goto OPARG_ARG; + + /* OP_PUSHVS var{symbol} + Pushes the value of the symbol VAR onto the stack. + VAR should be either a special variable or a constant. + */ + case OP_PUSHVS: string = "PUSHVS\t"; + s = next_code(vector); + goto ARG; + + /* OP_PUSHQ value{object} + Pushes "value" onto the stack. + */ + case OP_PUSHQ: string = "PUSH\t'"; + s = next_code(vector); + goto ARG; + + /* OP_PUSHVALUES + Pushes the values output by the last form. + */ + case OP_PUSHVALUES: string = "PUSH\tVALUES"; + goto NOARG; + case OP_BLOCK: vector = disassemble_block(vector); break; - case OP_PUSHVALUES: string = "PUSH\tVALUES"; goto NOARG; - case OP_MCALL: string = "MCALL"; goto NOARG; - case OP_CALL: string = "CALL"; + + /* OP_CALL n{arg}, function-name{symbol} + Calls the local or global function with N arguments + which have been deposited in the stack. The output + value is kept in VALUES(...) + */ + case OP_CALL: string = "CALL\t"; n = get_oparg(s); s = next_code(vector); goto OPARG_ARG; - case OP_PCALL: string = "PCALL"; + + /* OP_CALLG n{arg}, function-name{symbol} + Calls the global function with N arguments which have + been deposited in the stack. The output values are + left in VALUES(...) + */ + case OP_CALLG: string = "CALLG\t"; n = get_oparg(s); s = next_code(vector); goto OPARG_ARG; - case OP_CALLG: string = "FCALL"; + + /* OP_FCALL n{arg} + Calls the function in VALUES(0) with N arguments which + have been deposited in the stack. The output values + are left in VALUES(...) + */ + case OP_FCALL: string = "FCALL\t"; n = get_oparg(s); goto OPARG; - case OP_PCALLG: string = "PFCALL"; - n = get_oparg(s); - goto OPARG; - case OP_FCALL: string = "FCALL"; - n = get_oparg(s); - goto OPARG; - case OP_PFCALL: string = "PFCALL"; + + /* OP_PCALL n{arg}, function-name{symbol} + Calls the local or global function with N arguments + which have been deposited in the stack. The first + output value is pushed onto the stack. + */ + case OP_PCALL: string = "PCALL\t"; + n = get_oparg(s); + s = next_code(vector); + goto OPARG_ARG; + + /* OP_PCALLG n{arg}, function-name{symbol} + Calls the global function with N arguments which have + been deposited in the stack. The first output value is + left on the stack. + */ + case OP_PCALLG: string = "PCALLG\t"; + n = get_oparg(s); + s = next_code(vector); + goto OPARG_ARG; + + /* OP_PFCALL n{arg} + Calls the function in VALUES(0) with N arguments which + have been deposited in the stack. The first output value + is pushed on the stack. + */ + case OP_PFCALL: string = "PFCALL\t"; n = get_oparg(s); goto OPARG; + + case OP_MCALL: vector = disassemble_mcall(vector); + break; case OP_CATCH: vector = disassemble_catch(vector); break; + + /* OP_EXIT + Marks the end of a high level construct (BLOCK, CATCH...) + */ case OP_EXIT: printf("EXIT"); return vector; + + /* OP_HALT + Marks the end of a function. + */ case OP_HALT: printf("HALT"); return vector-1; + case OP_FLET: vector = disassemble_flet(vector); break; case OP_LABELS: vector = disassemble_labels(vector); break; - case OP_FUNCTION: string = "SYMFUNC"; + + /* OP_FUNCTION name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_FUNCTION: string = "SYMFUNC\t"; s = next_code(vector); goto ARG; - case OP_CLOSE: string = "CLOSE"; + + /* OP_CLOSE name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_CLOSE: string = "CLOSE\t"; s = next_code(vector); goto ARG; - case OP_GO: string = "GO"; + + /* OP_GO n{arg}, tag-name{symbol} + Jumps to the tag which is defined at the n-th position in + the lexical environment. TAG-NAME is kept for debugging + purposes. + */ + case OP_GO: string = "GO\t"; + n = get_oparg(s); s = next_code(vector); - goto ARG; + goto OPARG_ARG; + + /* OP_RETURN block-name{symbol} + Returns from the block whose name is BLOCK-NAME. + */ case OP_RETURN: string = "RETFROM"; s = next_code(vector); goto ARG; - case OP_THROW: string = "THROW"; goto NOARG; - case OP_JMP: string = "JMP"; + + /* OP_THROW + Jumps to an enclosing CATCH form whose tag matches the one + of the THROW. The tag is taken from the stack, while the + output values are left in VALUES(...). + */ + case OP_THROW: string = "THROW"; + goto NOARG; + + /* OP_JMP label{arg} + OP_JNIL label{arg} + OP_JT label{arg} + OP_JEQ label{arg}, value{object} + OP_JNEQ label{arg}, value{object} + Direct or conditional jumps. The conditional jumps are made + comparing with the value of VALUES(0). + */ + case OP_JMP: string = "JMP\t"; n = packed_label(vector-1); goto OPARG; - case OP_JNIL: string = "JNIL"; + case OP_JNIL: string = "JNIL\t"; n = packed_label(vector-1); goto OPARG; - case OP_JT: string = "JT"; + case OP_JT: string = "JT\t"; n = packed_label(vector-1); goto OPARG; - case OP_JEQ: string = "JEQ"; + case OP_JEQ: string = "JEQ\t"; s = next_code(vector); n = packed_label(vector-2); goto OPARG_ARG; - case OP_JNEQ: string = "JNEQ"; + case OP_JNEQ: string = "JNEQ\t"; s = next_code(vector); n = packed_label(vector-2); goto OPARG_ARG; - case OP_UNBIND: string = "UNBIND"; n = get_oparg(s); goto OPARG; - case OP_UNBINDS: string = "UNBINDS"; n = get_oparg(s); goto OPARG; - case OP_BIND: string = "BIND"; goto QUOTE; - case OP_BINDS: string = "BINDS"; goto QUOTE; - case OP_PBIND: string = "PBIND"; goto QUOTE; - case OP_PBINDS: string = "PBINDS"; goto QUOTE; - case OP_PSETQ: string = "PSETQ"; goto SETQ; - case OP_PSETQS: string = "PSETQS"; goto QUOTE; - case OP_SETQ: string = "SETQ"; - SETQ: s = next_code(vector); + + /* OP_UNBIND n{arg} + Undo "n" bindings of lexical variables. + */ + case OP_UNBIND: string = "UNBIND\t"; + n = get_oparg(s); + goto OPARG; + /* OP_UNBINDS n{arg} + Undo "n" bindings of special variables. + */ + case OP_UNBINDS: string = "UNBINDS\t"; + n = get_oparg(s); + goto OPARG; + /* OP_BIND name{symbol} + OP_PBIND name{symbol} + OP_BINDS name{symbol} + OP_PBINDS name{symbol} + Binds a lexical or special variable to the either the + value of VALUES(0), to the first value of the stack, or + to the n-th value of VALUES(...). + */ + case OP_BIND: string = "BIND\t"; + s = next_code(vector); goto ARG; - case OP_SETQS: string = "SETQS"; goto QUOTE; + case OP_PBIND: string = "PBIND\t"; + s = next_code(vector); + goto ARG; + case OP_VBIND: string = "VBIND\t"; + s = next_code(vector); + goto ARG; + case OP_BINDS: string = "BINDS\t"; + s = next_code(vector); + goto ARG; + case OP_PBINDS: string = "PBINDS\t"; + s = next_code(vector); + goto ARG; + case OP_VBINDS: string = "VBINDS\t"; + s = next_code(vector); + goto ARG; + /* OP_SETQ n{arg} + OP_PSETQ n{arg} + OP_SETQS var-name{symbol} + OP_PSETQS var-name{symbol} + Sets either the n-th local or a special variable VAR-NAME, + to either the value in VALUES(0) (OP_SETQ[S]) or to the + first value on the stack (OP_PSETQ[S]). + */ + case OP_SETQ: string = "SETQ\t"; + n = get_oparg(s); + goto OPARG; + case OP_PSETQ: string = "PSETQ\t"; + n = get_oparg(s); + goto OPARG; + case OP_SETQS: string = "SETQS"; + s = next_code(vector); + goto ARG; + case OP_PSETQS: string = "PSETQS"; + s = next_code(vector); + goto ARG; + case OP_MSETQ: vector = disassemble_msetq(vector); break; - case OP_MBIND: vector = disassemble_mbind(vector); - break; case OP_MPROG1: vector = disassemble_mprog1(vector); break; case OP_PROGV: vector = disassemble_progv(vector); break; - case OP_VALUES: string = "VALUES"; + + /* OP_VALUES n{arg} + Pop N values from the stack and store them in VALUES(...) + */ + case OP_VALUES: string = "VALUES\t"; n = get_oparg(s); goto OPARG; - case OP_NTHVAL: string = "NTHVAL"; goto NOARG; + /* OP_NTHVAL + Set VALUES(0) to the N-th value of the VALUES(...) list. + The index N-th is extracted from the top of the stack. + */ + case OP_NTHVAL: string = "NTHVAL\t"; + goto NOARG; case OP_DOLIST: vector = disassemble_dolist(vector); break; case OP_DOTIMES: vector = disassemble_dotimes(vector); @@ -467,12 +762,12 @@ disassemble(cl_object *vector) { return vector; NOARG: printf(string); break; - ARG: printf("%s\t", string); + ARG: printf(string); @prin1(1, s); break; - OPARG: printf("%s\t%d", string, n); + OPARG: printf("%s%d", string, n); break; - OPARG_ARG: printf("%s\t%d,", string, n); + OPARG_ARG: printf("%s%d,", string, n); @prin1(1, s); break; } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 28d0b2aee..defa3cb1a 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -141,21 +141,19 @@ bind_special(register cl_object var, register cl_object val) static cl_object search_local(register cl_object name, register int s) { cl_object x; - for (x = lex_env; s-- && !Null(x); x = CDDR(x)); + for (x = lex_env; s-- > 0 && !Null(x); x = CDDR(x)); if (Null(x) || CAR(x) != name) - FEerror("Internal error: local not found.", 0); + FEerror("Internal error: local not found.", 0); return CADR(x); } static void -setq_local(register cl_object s, register cl_object v) { +setq_local(register int s, register cl_object v) { cl_object x; - for (x = lex_env; CONSP(x); x = CDDR(x)) - if (CAR(x) == s) { - CADR(x) = v; - return; - } - FEerror("Internal error: local ~S not found.", 1, s); + for (x = lex_env; s-- > 0 && !Null(x); x = CDDR(x)); + if (Null(x)) + FEerror("Internal error: local ~S not found.", 1, s); + CADR(x) = v; } static cl_object @@ -491,6 +489,14 @@ interpret_funcall(int narg, cl_object fun) { /* -------------------- THE INTERPRETER -------------------- */ +/* OP_BLOCK label{arg}, block-name{symbol} + ... + OP_EXIT + label: + + Executes the enclosed code in a named block. + LABEL points to the first instruction after OP_EXIT. +*/ static cl_object * interpret_block(cl_object *vector) { cl_object * volatile exit, name; @@ -511,6 +517,8 @@ interpret_block(cl_object *vector) { return exit; } + + static cl_object * interpret_catch(cl_object *vector) { cl_object * volatile exit; @@ -521,6 +529,20 @@ interpret_catch(cl_object *vector) { return exit; } +/* OP_TAGBODY n{arg} + tag1 + label1 + ... + tagn + labeln +label1: + ... +labeln: + ... + OP_EXIT + + High level construct for the TAGBODY form. +*/ static cl_object * interpret_tagbody(cl_object *vector) { cl_index i, ntags = get_oparg(vector[-1]); @@ -551,6 +573,18 @@ interpret_tagbody(cl_object *vector) { return vector; } +/* OP_UNWIND label + ... ; code to be protected and whose value is output + OP_EXIT +label: + ... ; code executed at exit + OP_EXIT + High level construct for UNWIND-PROTECT. The first piece of code + is executed and its output value is saved. Then the second piece + of code is executed and the output values restored. The second + piece of code is always executed, even if a THROW, RETURN or GO + happen within the first piece of code. +*/ static cl_object * interpret_unwind_protect(cl_object *vector) { volatile int nr; @@ -574,6 +608,13 @@ interpret_unwind_protect(cl_object *vector) { return exit; } +/* OP_DO label + ... ; code executed within a NIL block + OP_EXIT + label: + + High level construct for the DO and BLOCK forms. +*/ static cl_object * interpret_do(cl_object *vector) { cl_object *volatile exit; @@ -596,6 +637,18 @@ interpret_do(cl_object *vector) { return exit; } +/* OP_DOLIST label + ... ; code to bind the local variable + OP_EXIT + ... ; code executed on each iteration + OP_EXIT + ... ; code executed at the end + OP_EXIT + label: + + High level construct for the DOLIST iterator. The list over which + we iterate is stored in VALUES(0). +*/ static cl_object * interpret_dolist(cl_object *vector) { cl_object *output, *volatile exit; @@ -635,6 +688,18 @@ interpret_dolist(cl_object *vector) { return exit; } +/* OP_TIMES label + ... ; code to bind the local variable + OP_EXIT + ... ; code executed on each iteration + OP_EXIT + ... ; code executed at the end + OP_EXIT + label: + + High level construct for the DOTIMES iterator. The number of times + we iterate is stored in VALUES(0). +*/ static cl_object * interpret_dotimes(cl_object *vector) { cl_object *output, *volatile exit; @@ -680,6 +745,16 @@ close_around(cl_object fun, cl_object lex) { return v; } +/* OP_FLET nfun{arg} + fun1{object} + ... + funn{object} + ... + OP_EXIT + + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". +*/ static cl_object * interpret_flet(cl_object *vector) { cl_index nfun = get_oparg(vector[-1]); @@ -697,6 +772,16 @@ interpret_flet(cl_object *vector) { return vector; } +/* OP_FLET nfun{arg} + fun1{object} + ... + funn{object} + ... + OP_EXIT + + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". +*/ static cl_object * interpret_labels(cl_object *vector) { cl_index i, nfun = get_oparg(vector[-1]); @@ -717,21 +802,13 @@ interpret_labels(cl_object *vector) { return vector; } -static cl_object * -interpret_mbind(cl_object *vector) -{ - int i = get_oparg(vector[-1]); - while (i--) { - cl_object var = next_code(vector); - cl_object value = (i < NValues) ? VALUES(i) : Cnil; - if (var == MAKE_FIXNUM(1)) - bind_special(next_code(vector), value); - else - bind_var(var, value); - } - return vector; -} +/* OP_MCALL + ... + OP_EXIT + Saves the stack pointer, executes the enclosed code and + funcalls VALUE(0) using the content of the stack. +*/ static cl_object * interpret_mcall(cl_object *vector) { cl_index sp = cl_stack_index(); @@ -740,6 +817,13 @@ interpret_mcall(cl_object *vector) { return vector; } +/* OP_PROG1 + ... + OP_EXIT + + Save the values in VALUES(..), execute the code enclosed, and + restore the values. +*/ static cl_object * interpret_mprog1(cl_object *vector) { cl_index i,n = NValues; @@ -754,6 +838,16 @@ interpret_mprog1(cl_object *vector) { return vector; } +/* OP_MSETQ n{arg} + {fixnumn}|{symboln} + ... + {fixnum1}|{symbol1} + + Sets N variables to the N values in VALUES(), filling with + NIL when there are values missing. Local variables are denoted + with an integer which points a position in the lexical environment, + while special variables are denoted just with the name. +*/ static cl_object * interpret_msetq(cl_object *vector) { @@ -762,10 +856,9 @@ interpret_msetq(cl_object *vector) while (i--) { var = next_code(vector); value = (i < NValues) ? VALUES(i) : Cnil; - if (var != MAKE_FIXNUM(1)) - setq_local(var, value); + if (FIXNUMP(var)) + setq_local(fix(var), value); else { - var = next_code(vector); if (var->symbol.stype == stp_constant) FEassignment_to_constant(var); else @@ -776,6 +869,12 @@ interpret_msetq(cl_object *vector) return vector; } +/* OP_PROGV bindings{list} + ... + OP_EXIT + Execute the code enclosed with the special variables in BINDINGS + set to the values in the list which was passed in VALUES(0). +*/ static cl_object * interpret_progv(cl_object *vector) { cl_object values = VALUES(0); @@ -818,59 +917,110 @@ interpret(cl_object *vector) { goto BEGIN; } switch (GET_OP(s)) { - case OP_PUSHQ: - cl_stack_push(next_code(vector)); - break; - case OP_PUSH: - cl_stack_push(VALUES(0)); - break; - case OP_PUSHV: - cl_stack_push(search_local(next_code(vector), get_oparg(s))); - break; - case OP_PUSHVS: - cl_stack_push(search_global(next_code(vector))); - break; - case OP_VAR: - VALUES(0) = search_local(next_code(vector), get_oparg(s)); - NValues = 1; - break; - case OP_VARS: - VALUES(0) = search_global(next_code(vector)); - NValues = 1; - break; - case OP_QUOTE: - VALUES(0) = next_code(vector); - NValues = 1; - break; + /* OP_NOP + Sets VALUES(0) = NIL and NValues = 1 + */ case OP_NOP: VALUES(0) = Cnil; NValues = 0; break; - case OP_BLOCK: - vector = interpret_block(vector); + + /* OP_QUOTE + Sets VALUES(0) to an immediate value. + */ + case OP_QUOTE: + VALUES(0) = next_code(vector); + NValues = 1; break; + + /* OP_VAR n{arg}, var{symbol} + Sets NValues=1 and VALUES(0) to the value of the n-th local. + VAR is the name of the variable for readability purposes. + */ + case OP_VAR: { + int lex_env_index = get_oparg(s); + cl_object var_name = next_code(vector); + VALUES(0) = search_local(var_name, lex_env_index); + NValues = 1; + break; + } + + /* OP_VARS var{symbol} + Sets NValues=1 and VALUES(0) to the value of the symbol VAR. + VAR should be either a special variable or a constant. + */ + case OP_VARS: { + cl_object var_name = next_code(vector); + VALUES(0) = search_global(var_name); + NValues = 1; + break; + } + + /* OP_PUSH + Pushes the object in VALUES(0). + */ + case OP_PUSH: + cl_stack_push(VALUES(0)); + break; + + /* OP_PUSHV n{arg}, var{symbol} + Pushes the value of the n-th local onto the stack. + VAR is the name of the variable for readability purposes. + */ + case OP_PUSHV: { + int lex_env_index = get_oparg(s); + cl_object var_name = next_code(vector); + cl_stack_push(search_local(var_name, lex_env_index)); + break; + } + + /* OP_PUSHVS var{symbol} + Pushes the value of the symbol VAR onto the stack. + VAR should be either a special variable or a constant. + */ + case OP_PUSHVS: { + cl_object var_name = next_code(vector); + cl_stack_push(search_global(var_name)); + break; + } + + /* OP_PUSHQ value{object} + Pushes "value" onto the stack. + */ + case OP_PUSHQ: + cl_stack_push(next_code(vector)); + break; + + /* OP_PUSHVALUES + Pushes the values output by the last form. + */ case OP_PUSHVALUES: { int i; for (i=0; isymbol.gfdef); break; } + + /* OP_FCALL n{arg} + Calls the function in VALUES(0) with N arguments which + have been deposited in the stack. The output values + are left in VALUES(...) + */ case OP_FCALL: { cl_fixnum n = get_oparg(s); cl_object fun = VALUES(0); VALUES(0) = interpret_funcall(n, fun); break; } + + /* OP_PCALL n{arg}, function-name{symbol} + Calls the local or global function with N arguments + which have been deposited in the stack. The first + output value is pushed onto the stack. + */ + case OP_PCALL: { + cl_fixnum n = get_oparg(s); + cl_object name = next_code(vector); + VALUES(0) = interpret_call(n, name); + cl_stack_push(VALUES(0)); + break; + } + + /* OP_PCALLG n{arg}, function-name{symbol} + Calls the global function with N arguments which have + been deposited in the stack. The first output value is + left on the stack. + */ case OP_PCALLG: { cl_fixnum n = get_oparg(s); cl_object fun = next_code(vector); @@ -894,6 +1069,12 @@ interpret(cl_object *vector) { cl_stack_push(VALUES(0)); break; } + + /* OP_PFCALL n{arg} + Calls the function in VALUES(0) with N arguments which + have been deposited in the stack. The first output value + is pushed on the stack. + */ case OP_PFCALL: { cl_fixnum n = get_oparg(s); cl_object fun = VALUES(0); @@ -901,11 +1082,23 @@ interpret(cl_object *vector) { cl_stack_push(VALUES(0)); break; } + + case OP_MCALL: + vector = interpret_mcall(vector); + break; case OP_CATCH: vector = interpret_catch(vector); break; + + /* OP_EXIT + Marks the end of a high level construct (BLOCK, CATCH...) + */ case OP_EXIT: return vector; + + /* OP_HALT + Marks the end of a function. + */ case OP_HALT: return vector-1; case OP_FLET: @@ -914,33 +1107,71 @@ interpret(cl_object *vector) { case OP_LABELS: vector = interpret_labels(vector); break; - case OP_FUNCTION: - VALUES(0) = search_symbol_function(next_code(vector)); + + /* OP_FUNCTION name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_FUNCTION: { + cl_object function_name = next_code(vector); + VALUES(0) = search_symbol_function(function_name); NValues = 1; break; - case OP_CLOSE: - VALUES(0) = close_around(next_code(vector), lex_env); + } + /* OP_CLOSE name{symbol} + Extracts the function associated to a symbol. The function + may be defined in the global environment or in the local + environment. This last value takes precedence. + */ + case OP_CLOSE: { + cl_object function_object = next_code(vector); + VALUES(0) = close_around(function_object, lex_env); NValues = 1; break; + } + /* OP_GO n{arg}, tag-name{symbol} + Jumps to the tag which is defined at the n-th position in + the lexical environment. TAG-NAME is kept for debugging + purposes. + */ case OP_GO: { - cl_object tag = next_code(vector); + cl_object tag_name = next_code(vector); cl_object id = search_local(@':tag',get_oparg(s)); VALUES(0) = Cnil; NValues = 0; - cl_go(id, tag); + cl_go(id, tag_name); break; } + /* OP_RETURN block-name{symbol} + Returns from the block whose name is BLOCK-NAME. + */ case OP_RETURN: { - cl_object tag = next_code(vector); - cl_object id = search_tag(tag, @':block'); + cl_object block_name = next_code(vector); + cl_object id = search_tag(block_name, @':block'); if (Null(id)) - FEcontrol_error("RETURN-FROM: Unknown block ~S.", 1, tag); - cl_return_from(id, tag); + FEcontrol_error("RETURN-FROM: Unknown block ~S.", 1, block_name); + cl_return_from(id, block_name); break; } - case OP_THROW: - cl_throw(cl_stack_pop()); + /* OP_THROW + Jumps to an enclosing CATCH form whose tag matches the one + of the THROW. The tag is taken from the stack, while the + output values are left in VALUES(...). + */ + case OP_THROW: { + cl_object tag_name = cl_stack_pop(); + cl_throw(tag_name); break; + } + /* OP_JMP label{arg} + OP_JNIL label{arg} + OP_JT label{arg} + OP_JEQ label{arg}, value{object} + OP_JNEQ label{arg}, value{object} + Direct or conditional jumps. The conditional jumps are made + comparing with the value of VALUES(0). + */ case OP_JMP: vector = vector - 1 + get_oparg(s); break; @@ -960,24 +1191,81 @@ interpret(cl_object *vector) { if (VALUES(0) != next_code(vector)) vector = vector + get_oparg(s) - 2; break; + /* OP_UNBIND n{arg} + Undo "n" local bindings. + */ case OP_UNBIND: { cl_index n = get_oparg(s); while (n--) lex_env = CDDR(lex_env); break; } - case OP_UNBINDS: - bds_unwind(bds_top - get_oparg(s)); + /* OP_UNBINDS n{arg} + Undo "n" bindings of special variables. + */ + case OP_UNBINDS: { + cl_index n = get_oparg(s); + bds_unwind_n(n); break; - case OP_BIND: - bind_var(next_code(vector), VALUES(0)); + } + /* OP_BIND name{symbol} + OP_PBIND name{symbol} + OP_BINDS name{symbol} + OP_PBINDS name{symbol} + Binds a lexical or special variable to the either the + value of VALUES(0) or the first value of the stack. + */ + case OP_BIND: { + cl_object var_name = next_code(vector); + cl_object value = VALUES(0); + bind_var(var_name, value); break; - case OP_BINDS: - bind_special(next_code(vector), VALUES(0)); + } + case OP_PBIND: { + cl_object var_name = next_code(vector); + cl_object value = cl_stack_pop(); + bind_var(var_name, value); break; - case OP_SETQ: - setq_local(next_code(vector), VALUES(0)); + } + case OP_VBIND: { + int n = get_oparg(s); + cl_object var_name = next_code(vector); + cl_object value = (--n < NValues) ? VALUES(n) : Cnil; + bind_var(var_name, value); break; + } + case OP_BINDS: { + cl_object var_name = next_code(vector); + cl_object value = VALUES(0); + bind_special(var_name, value); + break; + } + case OP_PBINDS: { + cl_object var_name = next_code(vector); + cl_object value = cl_stack_pop(); + bind_special(var_name, value); + break; + } + case OP_VBINDS: { + int n = get_oparg(s); + cl_object var_name = next_code(vector); + cl_object value = (--n < NValues) ? VALUES(n) : Cnil; + bind_special(var_name, value); + break; + } + /* OP_SETQ n{arg} + OP_PSETQ n{arg} + OP_SETQS var-name{symbol} + OP_PSETQS var-name{symbol} + Sets either the n-th local or a special variable VAR-NAME, + to either the value in VALUES(0) (OP_SETQ[S]) or to the + first value on the stack (OP_PSETQ[S]). + */ + case OP_SETQ: { + int lex_env_index = get_oparg(s); + setq_local(lex_env_index, VALUES(0)); + break; + } case OP_SETQS: { cl_object var = next_code(vector); if (var->symbol.stype == stp_constant) @@ -986,17 +1274,13 @@ interpret(cl_object *vector) { SYM_VAL(var) = VALUES(0); break; } - case OP_PBIND: - bind_var(next_code(vector), cl_stack_pop()); - break; - case OP_PBINDS: - bind_special(next_code(vector), cl_stack_pop()); - break; - case OP_PSETQ: - setq_local(next_code(vector), cl_stack_pop()); + case OP_PSETQ: { + int lex_env_index = get_oparg(s); + setq_local(lex_env_index, cl_stack_pop()); Values[0] = Cnil; NValues = 1; break; + } case OP_PSETQS: { cl_object var = next_code(vector); if (var->symbol.stype == stp_constant) @@ -1010,15 +1294,16 @@ interpret(cl_object *vector) { case OP_MSETQ: vector = interpret_msetq(vector); break; - case OP_MBIND: - vector = interpret_mbind(vector); - break; case OP_MPROG1: vector = interpret_mprog1(vector); break; case OP_PROGV: vector = interpret_progv(vector); break; + + /* OP_VALUES n{arg} + Pop N values from the stack and store them in VALUES(...) + */ case OP_VALUES: { cl_fixnum n = get_oparg(s); NValues = n; @@ -1026,6 +1311,10 @@ interpret(cl_object *vector) { VALUES(--n) = cl_stack_pop(); break; } + /* OP_NTHVAL + Set VALUES(0) to the N-th value of the VALUES(...) list. + The index N-th is extracted from the top of the stack. + */ case OP_NTHVAL: { cl_fixnum n = fix(cl_stack_pop()); if (n < 0 || n >= NValues) diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index ab4956a05..f87f6de79 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -17,21 +17,21 @@ OP_PUSHVS var{symbol} Pushes the value of the symbol VAR onto the stack. - OP_VAR n{arg}, var{symbol} - Returns the value of the n-th local. VAR is given for readability - of diassembled code only. + OP_VAR n{arg} + Returns the value of the n-th local. OP_VARS var{symbol} Returns the value of the symbol VAR. OP_PUSHQ value{obj} - Pushes "value" + Pushes "value" onto the stack. - OP_PUSHV var{symbol} - Pushes the value of the variable "var" + OP_PUSHV n{arg}, var{symbol} + Pushes the value of the n-th local. The name of the variable is + kept for readability purposes. OP_PUSHVALUES - Pushes the values output by the last form + Pushes the values output by the last form. OP_MCALL ... @@ -149,9 +149,10 @@ enum { OP_PBINDS, OP_PSETQ, OP_PSETQS, + OP_VBIND, + OP_VBINDS, OP_UNBIND, OP_UNBINDS, - OP_MBIND, OP_MSETQ, OP_PROGV, OP_VALUES, diff --git a/src/h/stacks.h b/src/h/stacks.h index 15851140b..b58120b0f 100644 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -211,23 +211,18 @@ extern cl_object Values[VSSIZE]; * LEXICAL ENVIRONMENT STACK *****************************/ /* - |---------------| -lex_env ------> | lex-var | : lex_env[0] - |---------------| - | lex-fd | : lex_env[1] - |---------------| - | lex-tag | : lex_env[2] - |---------------| - lex-var: (symbol value) ; for local binding - or (symbol) ; for special binding - lex-fd: (fun-name 'FUNCTION' function) - or (macro-name 'MACRO' expansion-function) +lex_env ------> ( tag0 value0 tag1 value1 ... ) - lex-tag: (tag 'TAG' frame-id) - or (block-name 'BLOCK' frame-id) + tag: variable-name (symbol) + value: variable-value (any lisp object) + + tag: :function + value: (function-name . function-object) + + tag: :block + value: (block-name . frame-id) -where 'FUN' is the LISP symbol with pname FUN, etc. */ #ifdef THREADS