From ee391629b6effaeed231da0d0f40c9cfa272c4e7 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Tue, 5 Aug 2003 10:01:57 +0000 Subject: [PATCH] New bytecodes compiler and interpreter, which use 8-bits large bytecodes and 16-bits large arguments. Macros are implemented as two-argument functions, leaving argument checking to funcall() and apply() and thus saving space. AND, WHEN and OR are plain macros. No optimizer is required in the bytecodes compiler. --- src/CHANGELOG | 16 ++ src/c/alloc.d | 8 +- src/c/cfun.d | 5 +- src/c/cinit.d | 3 +- src/c/compiler.d | 510 +++++++++++++++++++---------------------- src/c/disassembler.d | 343 ++++++++++++--------------- src/c/eval.d | 14 +- src/c/gbc.d | 4 +- src/c/interpreter.d | 374 +++++++++++++++--------------- src/c/load.d | 3 +- src/c/macros.d | 46 ++++ src/c/read.d | 4 +- src/c/tclBasic.d | 2 +- src/cmp/cmplam.lsp | 2 - src/cmp/cmptop.lsp | 15 +- src/doc/help.lsp | 14 ++ src/h/bytecodes.h | 25 +- src/h/external.h | 9 +- src/h/internal.h | 4 + src/h/object.h | 6 +- src/lsp/evalmacros.lsp | 38 --- 21 files changed, 705 insertions(+), 740 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 2be4514be..5e9fb5f13 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1450,6 +1450,22 @@ ECLS 0.9b - EQL specializers were compared to the arguments using EQ instead of EQL. +* System design: + + - The bytecodes compiler now works with character arrays. Bytecodes + are thus 8 bits large, while their arguments are 16 bits large. + Lisp objects referenced in the code are kept in a separate array + to simplify garbage collection. This strategy limits the size of + bytecode objects to about 32000 bytes and about 32000 constants, + but reduces the use of memory by about 25%. + + - Macros are implemented in C as functions with two arguments. + Argument checking is thus left to funcall() and apply(), saving + space. + + - AND, OR and WHEN are now just macros, without any special + treatment in the bytecodes compiler. + * Visible changes: - New special form C-INLINE, allows inserting C/C++ code in any diff --git a/src/c/alloc.d b/src/c/alloc.d index 529567320..a5e24313b 100644 --- a/src/c/alloc.d +++ b/src/c/alloc.d @@ -221,8 +221,8 @@ cl_alloc_object(cl_type t) return CODE_CHAR('\0'); /* Immediate character */ default: } - - start_critical_section(); + + start_critical_section(); tm = tm_of(t); ONCE_MORE: if (interrupt_flag) { @@ -346,7 +346,9 @@ ONCE_MORE: obj->bytecodes.name = Cnil; obj->bytecodes.definition = Cnil; obj->bytecodes.specials = Cnil; - obj->bytecodes.size = 0; + obj->bytecodes.code_size = 0; + obj->bytecodes.code = NULL; + obj->bytecodes.data_size = 0; obj->bytecodes.data = NULL; break; case t_cfun: diff --git a/src/c/cfun.d b/src/c/cfun.d index 86a4b8637..45097f199 100644 --- a/src/c/cfun.d +++ b/src/c/cfun.d @@ -65,9 +65,10 @@ cl_def_c_function(cl_object sym, cl_object (*self)(), int narg) } void -cl_def_c_macro_va(cl_object sym, cl_objectfn self) +cl_def_c_macro(cl_object sym, cl_object (*self)(cl_object, cl_object)) { - si_fset(3, sym, cl_make_cfun_va(self, sym, symbol_value(@'si::*cblock*')), + si_fset(3, sym, + cl_make_cfun(self, sym, symbol_value(@'si::*cblock*'), 2), Ct); } diff --git a/src/c/cinit.d b/src/c/cinit.d index 6ce4b5461..2e205cabc 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -33,12 +33,11 @@ static cl_object si_simple_toplevel () cl_load(1, arg); } while (1) { - cl_object bytecodes = Cnil; printf("\n> "); sentence = @read(3, Cnil, Cnil, OBJNULL); if (sentence == OBJNULL) @(return); - prin1(eval(sentence, &bytecodes, Cnil), Cnil); + prin1(si_eval_with_env(sentence, Cnil), Cnil); #ifdef TK StdinResume(); #endif diff --git a/src/c/compiler.d b/src/c/compiler.d index fc9b4488c..488634bcd 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -12,9 +12,23 @@ See file '../Copyright' for full details. */ +/* Remarks: + + [1] The virtual machine has a word size of 16 bits. Operands and arguments + have this very size, so that for instance, a jump + + OP_JMP increment + + takes two words of memory: one for the operator and one for the argument. + The interpreter is written with this assumption in mind, but it should be + easily modifed, because arguments are retrieved with "next_arg" and + operators with "next_op". Parts which will require a careful modification + are marked with flag [1]. +*/ #include #include "ecl.h" #include "ecl-inl.h" +#include "internal.h" #include "bytecodes.h" /********************* EXPORTS *********************/ @@ -34,9 +48,11 @@ #define FLAG_USEFUL (FLAG_PUSH | FLAG_VALUES) typedef struct { + bool coalesce; cl_object variables; cl_object macros; cl_fixnum lexical_level; + cl_object constants; #ifdef CL_COMP_OWN_STACK cl_object bytecodes; #endif @@ -52,24 +68,20 @@ static void set_pc(cl_index pc); static cl_object asm_ref(register cl_index where); static cl_index asm_begin(void); static void asm_clear(cl_index); -static void asm1(register cl_object op); -static void asm_at(register cl_index where, register cl_object what); +static void asm_op(register int op); #else #define asm_begin() cl_stack_index() #define asm_clear(h) cl_stack_set_index(h) #define current_pc() cl_stack_index() #define set_pc(n) cl_stack_set_index(n) -#define asm1(o) cl_stack_push(o) -#define asm_ref(n) cl_stack[n] -#define asm_at(n,o) cl_stack[n] = o +#define asm_op(o) cl_stack_push((cl_object)(o)) +#define asm_ref(n) (cl_fixnum)(cl_stack[n]) #endif -#define asm_op(n) asm1(MAKE_FIXNUM(n)) -static cl_object asm_end(cl_index handle, cl_object bytecodes); -static void asm_list(register cl_object l); +static void asm_op2(int op, int arg); +static cl_object asm_end(cl_index handle); static cl_index asm_jmp(register int op); static void asm_complete(register int op, register cl_index original); -static int c_and(cl_object args, int flags); static int c_block(cl_object args, int flags); static int c_case(cl_object args, int flags); static int c_catch(cl_object args, int flags); @@ -96,7 +108,6 @@ static int c_multiple_value_prog1(cl_object args, int flags); static int c_multiple_value_setq(cl_object args, int flags); static int c_not(cl_object args, int flags); static int c_nth_value(cl_object args, int flags); -static int c_or(cl_object args, int flags); static int c_prog1(cl_object args, int flags); static int c_progv(cl_object args, int flags); static int c_psetq(cl_object args, int flags); @@ -108,7 +119,6 @@ static int c_symbol_macrolet(cl_object args, int flags); static int c_tagbody(cl_object args, int flags); static int c_throw(cl_object args, int flags); static int c_unwind_protect(cl_object args, int flags); -static int c_when(cl_object args, int flags); static int compile_body(cl_object args, int flags); static int compile_form(cl_object args, int push); @@ -145,7 +155,7 @@ pop_maybe_nil(cl_object *l) { static cl_object alloc_bytecodes() { - cl_object vector = cl_alloc_simple_vector(128, aet_object); + cl_object vector = cl_alloc_simple_vector(128, aet_fix); array_allocself(vector); vector->vector.hasfillp = TRUE; vector->vector.fillp = 0; @@ -175,21 +185,14 @@ asm_grow(void) { } static void -asm1(register cl_object op) { +asm_op(register int op) { int where = c_env.bytecodes->vector.fillp; if (where >= c_env.bytecodes->vector.dim) asm_grow(); - c_env.bytecodes->vector.self.t[where] = op; + c_env.bytecodes->vector.self.fix[where] = op; c_env.bytecodes->vector.fillp++; } -static void -asm_at(register cl_index where, register cl_object what) { - if (where > c_env.bytecodes->vector.fillp) - FEprogram_error("Internal error at asm_at()",0); - c_env.bytecodes->vector.self.t[where] = what; -} - static cl_index current_pc(void) { return c_env.bytecodes->vector.fillp; @@ -200,86 +203,94 @@ set_pc(cl_index pc) { c_env.bytecodes->vector.fillp = pc; } -static cl_object +static cl_fixnum asm_ref(register cl_index n) { - return c_env.bytecodes->vector.self.t[n]; + return c_env.bytecodes->vector.self.fix[n]; } #endif /* CL_COMP_OWN_STACK */ static cl_object -asm_end(cl_index beginning, cl_object bytecodes) { - cl_object new_bytecodes; - cl_index length, bytes; +asm_end(cl_index beginning) { + cl_object bytecodes; + cl_index code_size, data_size, i; /* Save bytecodes from this session in a new vector */ - length = current_pc() - beginning; - bytes = length * sizeof(cl_object); - if (!Null(bytecodes)) - new_bytecodes = bytecodes; - else { - new_bytecodes = cl_alloc_object(t_bytecodes); - new_bytecodes->bytecodes.size = 0; - } - new_bytecodes->bytecodes.lex = Cnil; - if (new_bytecodes->bytecodes.size < length) { - new_bytecodes->bytecodes.data = (cl_object *)cl_alloc(bytes); - new_bytecodes->bytecodes.size = length; - } else { - memset(new_bytecodes->bytecodes.data, 0, - new_bytecodes->bytecodes.size * sizeof(cl_object)); - } + code_size = current_pc() - beginning; + data_size = length(c_env.constants); + bytecodes = cl_alloc_object(t_bytecodes); + bytecodes->bytecodes.code_size = code_size; + bytecodes->bytecodes.data_size = data_size; + bytecodes->bytecodes.code = cl_alloc(code_size * sizeof(cl_opcode)); + bytecodes->bytecodes.data = cl_alloc(data_size * sizeof(cl_object)); + bytecodes->bytecodes.lex = Cnil; + for (i = 0; i < code_size; i++) { + bytecodes->bytecodes.code[i] = #ifdef CL_COMP_OWN_STACK - memcpy(new_bytecodes->bytecodes.data, - &c_env.bytecodes->vector.self.t[beginning], - bytes); + c_env.bytecodes->vector.self.fix[beginning+i]; #else - memcpy(new_bytecodes->bytecodes.data, - &cl_stack[beginning], - bytes); -#endif + (cl_fixnum)cl_stack[beginning+i]; +#endif + } + for (i=0; i < data_size; i++) { + bytecodes->bytecodes.data[i] = CAR(c_env.constants); + c_env.constants = CDR(c_env.constants); + } asm_clear(beginning); - return new_bytecodes; + return bytecodes; } +static void +asm_arg(int n) { +#ifdef WORDS_BIGENDIAN + asm_op((n >> 8)); + asm_op(n & 0xFF); +#else + asm_op(n & 0xFF); + asm_op((n >> 8)); +#endif +} static void -asm_op2(register int code, register cl_fixnum n) { - cl_object op = MAKE_FIXNUM(code); - cl_object new_op = SET_OPARG(op, n); +asm_op2(register int code, register int n) { if (n < -MAX_OPARG || MAX_OPARG < n) FEprogram_error("Argument to bytecode is too large", 0); - else - asm1(new_op); + asm_op(code); + asm_arg(n); } static void -asm_list(register cl_object l) { - if (ATOM(l)) - asm1(l); - while(!endp(l)) { - asm1(CAR(l)); - l = CDR(l); - } +asm_constant(cl_object c) +{ + c_env.constants = nconc(c_env.constants, CONS(c, Cnil)); } static cl_index asm_jmp(register int op) { - cl_index output = current_pc(); + cl_index output; asm_op(op); + output = current_pc(); + asm_arg(0); return output; } static void -asm_complete(register int op, register cl_index original) { - cl_fixnum delta = current_pc() - original; - cl_object code = asm_ref(original); - cl_object new_code = SET_OPARG(code, delta); - if (code != MAKE_FIXNUM(op)) +asm_complete(register int op, register cl_index pc) { + cl_fixnum delta = current_pc() - pc; /* [1] */ + if (op && (asm_ref(pc-1) != op)) FEprogram_error("Non matching codes in ASM-COMPLETE2", 0); else if (delta < -MAX_OPARG || delta > MAX_OPARG) FEprogram_error("Too large jump", 0); - else - asm_at(original, new_code); + else { + char low = delta & 0xFF; + char high = delta >> 8; +#ifdef ECL_OWN_STACK + c_env.bytecodes->vector.self.fix[pc] = low; + c_env.bytecodes->vector.self.fix[pc+1] = low; +#else + cl_stack[pc] = (cl_object)(cl_fixnum)low; + cl_stack[pc+1] = (cl_object)(cl_fixnum)high; +#endif + } } /* ------------------------------ COMPILER ------------------------------ */ @@ -291,7 +302,6 @@ typedef struct { } compiler_record; static compiler_record database[] = { - {@'and', c_and, 1}, {@'block', c_block, 1}, {@'case', c_case, 1}, {@'catch', c_catch, 1}, @@ -319,7 +329,6 @@ static compiler_record database[] = { {@'not', c_not, 1}, {@'nth-value', c_nth_value, 1}, {@'null', c_not, 1}, - {@'or', c_or, 1}, {@'progn', compile_body, 0}, {@'prog1', c_prog1, 1}, {@'progv', c_progv, 1}, @@ -332,7 +341,6 @@ static compiler_record database[] = { {@'throw', c_throw, 1}, {@'unwind-protect', c_unwind_protect, 1}, {@'values', c_values, 1}, - {@'when', c_when, 1}, {NULL, NULL, 1} }; @@ -350,6 +358,30 @@ FEill_formed_input() FEprogram_error("Improper list handled to the compiler.", 0); } +static int +c_register_constant(cl_object c) +{ + cl_object p = c_env.constants; + int n; + for (n = 0; !Null(p); n++, p=CDR(p)) { + if (c_env.coalesce && eql(CAR(p), c)) { + return n; + } + } + asm_constant(c); + return n; +} + +static void +asm_c(register cl_object o) { + asm_arg(c_register_constant(o)); +} + +static void +asm_op2c(register int code, register cl_object o) { + asm_op2(code, c_register_constant(o)); +} + static void c_register_block(cl_object name) { @@ -398,6 +430,8 @@ c_register_var(register cl_object var, bool special) static void c_new_env(cl_object env) { + c_env.coalesce = TRUE; + c_env.constants = Cnil; c_env.variables = Cnil; c_env.macros = Cnil; if (Null(env)) { @@ -506,12 +540,11 @@ c_pbind(cl_object var, cl_object specials) FEillegal_variable_name(var); else if (special = c_declared_special(var, specials)) { c_register_var(var, TRUE); - asm_op(OP_PBINDS); + asm_op2c(OP_PBINDS, var); } else { c_register_var(var, FALSE); - asm_op(OP_PBIND); + asm_op2c(OP_PBIND, var); } - asm1(var); return special; } @@ -523,12 +556,11 @@ c_bind(cl_object var, cl_object specials) FEillegal_variable_name(var); else if (special = c_declared_special(var, specials)) { c_register_var(var, TRUE); - asm_op(OP_BINDS); + asm_op2c(OP_BINDS, var); } else { c_register_var(var, FALSE); - asm_op(OP_BIND); + asm_op2c(OP_BIND, var); } - asm1(var); return special; } @@ -563,16 +595,13 @@ compile_setq(int op, cl_object var) if (!SYMBOLP(var)) FEillegal_variable_name(var); ndx = c_var_ref(var); - if (ndx >= 0) { - asm_op2(op, ndx); /* Lexical variable */ - return; - } else if (var->symbol.stype == stp_constant) - FEassignment_to_constant(var); - else if (op == OP_SETQ) - asm_op(OP_SETQS); /* Special variable */ - else - asm_op(OP_PSETQS); /* Special variable */ - asm1(var); + if (ndx < 0) { /* Not a lexical variable */ + if (var->symbol.stype == stp_constant) + FEassignment_to_constant(var); + ndx = c_register_constant(var); + op = (op == OP_SETQ)? OP_SETQS : OP_PSETQS; + } + asm_op2(op, ndx); } /* @@ -594,32 +623,15 @@ maybe_values(int flags) { /* -------------------- THE COMPILER -------------------- */ -static int -c_and(cl_object args, int flags) { - if (Null(args)) { - return compile_form(Ct, flags); - } else if (ATOM(args)) { - FEill_formed_input(); - } else { - compile_form(pop(&args), FLAG_VALUES); - if (!endp(args)) { - cl_index label = asm_jmp(OP_JNIL); - c_and(args, FLAG_VALUES); - asm_complete(OP_JNIL, label); - } - return FLAG_VALUES; - } -} - /* The OP_BLOCK operator encloses several forms within a block named BLOCK_NAME, thus catching any OP_RETFROM whose argument matches BLOCK_NAME. The end of this block is marked both by the OP_EXIT operator and the LABELZ which is packed within the OP_BLOCK operator. - + [OP_BLOCK + labelz] - block_name + name .... OP_EXIT_FRAME labelz: ... @@ -640,7 +652,7 @@ c_block(cl_object body, int flags) { labelz = asm_jmp(OP_DO); else { labelz = asm_jmp(OP_BLOCK); - asm1(name); + asm_c(name); } compile_body(body, flags); asm_op(OP_EXIT_FRAME); @@ -667,8 +679,9 @@ c_block(cl_object body, int flags) { while OP_PCALL and OP_PFCALL leave the first argument in the stack. - OP_CALL and OP_PCALL use the following symbol to retrieve the - function, while OP_FCALL and OP_PFCALL use the value in VALUES(0). + OP_CALL and OP_PCALL use the value in VALUES(0) to retrieve the + function, while OP_FCALL and OP_PFCALL use a value from the + stack. */ static int c_arguments(cl_object args) { @@ -689,16 +702,13 @@ c_call(cl_object args, int flags) { name = pop(&args); nargs = c_arguments(args); - if (SYMBOLP(name) && - ((flags & FLAG_GLOBAL) || Null(c_tag_ref(name, @':function')))) - { - /* Globally defined function */ - asm_op2(push? OP_PCALLG : OP_CALLG, nargs); - asm1(name); + if (SYMBOLP(name) && (flags & FLAG_GLOBAL)) { + asm_op2c(OP_FUNCTION, name); } else { - asm_function(name, FLAG_VALUES); - asm_op2(push? OP_PCALL : OP_CALL, nargs); + /* Fixme!! We can optimize the case of global functions! */ + asm_function(name, (flags & FLAG_GLOBAL) || FLAG_VALUES); } + asm_op2(push? OP_PCALL : OP_CALL, nargs); return flags; } @@ -747,24 +757,27 @@ perform_c_case(cl_object args, int flags) { cl_index labeln, labelz; if (CONSP(test)) { cl_index n = length(test); - while (n > 1) { + while (n-- > 1) { cl_object v = pop(&test); - cl_fixnum jump = (n--) * 2; - asm_op2(OP_JEQL, jump); - asm1(v); + asm_op(OP_JEQL); + asm_c(v); + asm_arg(n * (OPCODE_SIZE + OPARG_SIZE * 2) + + OPARG_SIZE); } test = CAR(test); } - labeln = asm_jmp(OP_JNEQL); - asm1(test); + asm_op(OP_JNEQL); + asm_c(test); + labeln = current_pc(); + asm_arg(0); compile_body(clause, flags); if (endp(args) && !(flags & FLAG_USEFUL)) { /* Ther is no otherwise. The test has failed and we need no output value. We simply close jumps. */ - asm_complete(OP_JNEQL, labeln); + asm_complete(0 & OP_JNEQL, labeln); } else { labelz = asm_jmp(OP_JMP); - asm_complete(OP_JNEQL, labeln); + asm_complete(0 & OP_JNEQL, labeln); perform_c_case(args, flags); asm_complete(OP_JMP, labelz); } @@ -834,14 +847,7 @@ c_compiler_let(cl_object args, int flags) { is retrieved so that if the label is in vector[0], then the destination is roughly vector + vector[0]. - 2) There are two types of labels, "packed labels" and "simple - labels". The first ones are packed in the upper bits of an - operator so that - destination = vector + vector[0]>>16 - Simple labels take the whole word and thus - destination = vector + fix(vector[0]) - - 3) The three jump forms are + 2) The three jump forms are [OP_JMP + label] ; Unconditional jump [OP_JNIL + label] ; Jump if VALUES(0) == Cnil @@ -895,8 +901,8 @@ c_cond(cl_object args, int flags) { the lexical environment is restored, and all bindings undone. [OP_DO + labelz] - labelz ... ; bindings + [JMP + labelt] labelb: ... ; body ... ; stepping forms labelt: ... ; test form @@ -982,7 +988,8 @@ c_do_doa(int op, cl_object args, int flags) { /* Compile test */ asm_complete(OP_JMP, labelt); compile_form(pop(&test), FLAG_VALUES); - asm_op2(OP_JNIL, labelb - current_pc()); + asm_op(OP_JNIL); + asm_arg(labelb - current_pc()); /* Compile output clauses */ flags = maybe_values(flags); @@ -1016,9 +1023,9 @@ c_do(cl_object args, int flags) { termination, the lexical environment is restored, and all bindings undone. - [OP_DOTIMES/OP_DOLIST + labelz] + [OP_DOTIMES/OP_DOLIST + labelz + labelo] ... ; bindings - [OP_EXIT + labelo] + OP_EXIT ... ; body ... ; stepping forms OP_EXIT @@ -1046,6 +1053,7 @@ c_dolist_dotimes(int op, cl_object args, int flags) { /* Compute list and enter loop */ compile_form(list, FLAG_VALUES); labelz = asm_jmp(op); + labelo = current_pc(); asm_arg(0); /* Bind block */ c_register_block(Cnil); @@ -1053,7 +1061,7 @@ c_dolist_dotimes(int op, cl_object args, int flags) { /* Initialize the variable */ compile_form((op == OP_DOLIST)? Cnil : MAKE_FIXNUM(0), FLAG_VALUES); c_bind(var, specials); - labelo = asm_jmp(OP_EXIT); + asm_op(OP_EXIT); /* From here on, declarations apply */ c_register_vars(specials); @@ -1064,7 +1072,7 @@ c_dolist_dotimes(int op, cl_object args, int flags) { asm_op(OP_EXIT); /* Output */ - asm_complete(OP_EXIT, labelo); + asm_complete(0, labelo); if (head != Cnil && CDR(head) != Cnil) FEprogram_error("DOLIST: Too many output forms.", 0); flags = maybe_values(flags); @@ -1113,7 +1121,7 @@ c_eval_when(cl_object args, int flags) { [OP_FLET/OP_FLABELS + nfun] fun1 ... - funn + fun2 ... OP_EXIT labelz: @@ -1153,7 +1161,7 @@ c_labels_flet(int op, cl_object args, int flags) { for (l = def_list; !endp(l); ) { cl_object definition = pop(&l); cl_object name = pop(&definition); - asm1(make_lambda(name, definition)); + asm_c(make_lambda(name, definition)); } /* If compiling a FLET form, add the function names to the lexical @@ -1168,6 +1176,7 @@ c_labels_flet(int op, cl_object args, int flags) { c_undo_bindings(old_c_env.variables); /* Restore and return */ + old_c_env.constants = c_env.constants; c_env = old_c_env; return flags; @@ -1183,8 +1192,7 @@ c_flet(cl_object args, int flags) { /* There are two operators that produce functions. The first one is - OP_FUNCTION - symbol + [OP_FUNCTION + name] which takes the function binding of SYMBOL. The second one is OP_CLOSE interpreted @@ -1205,20 +1213,17 @@ asm_function(cl_object function, int flags) { cl_object ndx = c_tag_ref(function, @':function'); if (Null(ndx)) { /* Globally defined function */ - asm_op(OP_FUNCTION); - asm1(function); + asm_op2c(OP_FUNCTION, function); } else { /* Function from a FLET/LABELS form */ asm_op2(OP_LFUNCTION, fix(ndx)); } } else if (CONSP(function) && CAR(function) == @'lambda') { - asm_op(OP_CLOSE); - asm1(make_lambda(Cnil, CDR(function))); + asm_op2c(OP_CLOSE, make_lambda(Cnil, CDR(function))); } else if (CONSP(function) && CAR(function) == @'lambda-block') { cl_object name = CADR(function); cl_object body = CDDR(function); - asm_op(OP_CLOSE); - asm1(make_lambda(name, body)); + asm_op2c(OP_CLOSE, make_lambda(name, body)); } else { FEprogram_error("FUNCTION: Not a valid argument ~S.", 1, function); } @@ -1235,7 +1240,7 @@ c_go(cl_object args, int flags) { if (!Null(args)) FEprogram_error("GO: Too many arguments.",0); asm_op2(OP_GO, fix(CAR(info))); - asm1(CDR(info)); + asm_c(CDR(info)); return flags; } @@ -1296,14 +1301,14 @@ c_labels(cl_object args, int flags) { OP_EXIT There are four forms which perform bindings - OP_PBIND ; Bind NAME in the lexical env. using - name ; a value from the stack - OP_PBINDS ; Bind NAME as special variable using - name ; a value from the stack - OP_BIND ; Bind NAME in the lexical env. using - name ; VALUES(0) - OP_BINDS ; Bind NAME as special variable using - name ; VALUES(0) + OP_PBIND name ; Bind NAME in the lexical env. using + ; a value from the stack + OP_PBINDS name ; Bind NAME as special variable using + ; a value from the stack + OP_BIND name ; Bind NAME in the lexical env. using + ; VALUES(0) + OP_BINDS name ; Bind NAME as special variable using + ; VALUES(0) After a variable has been bound, there are several ways to refer to it. @@ -1456,7 +1461,7 @@ c_multiple_value_bind(cl_object args, int flags) c_register_var(var, FALSE); asm_op2(OP_VBIND, n); } - asm1(var); + asm_c(var); } flags = compile_body(body, flags); c_undo_bindings(old_variables); @@ -1556,13 +1561,12 @@ c_multiple_value_setq(cl_object args, int flags) { if (!SYMBOLP(var)) FEillegal_variable_name(var); ndx = c_var_ref(var); - if (ndx >= 0) - asm1(MAKE_FIXNUM(ndx)); /* Lexical variable */ - else if (var->symbol.stype == stp_constant) - FEassignment_to_constant(var); - else { - asm1(var); + if (ndx < 0) { /* Global variable */ + if (var->symbol.stype == stp_constant) + FEassignment_to_constant(var); + ndx = -1-c_register_constant(var); } + asm_arg(ndx); } /* Assign to symbol-macros */ @@ -1612,24 +1616,6 @@ c_nth_value(cl_object args, int flags) { } -static int -c_or(cl_object args, int flags) { - if (Null(args)) { - return compile_form(Cnil, flags); - } else if (ATOM(args)) { - FEill_formed_input(); - } else { - compile_form(pop(&args), FLAG_VALUES); - if (!endp(args)) { - cl_index label = asm_jmp(OP_JT); - c_or(args, FLAG_VALUES); - asm_complete(OP_JT, label); - } - } - return FLAG_VALUES; -} - - static int c_prog1(cl_object args, int flags) { cl_object form = pop(&args); @@ -1690,8 +1676,7 @@ c_progv(cl_object args, int flags) { [OP_SETQ + n] 2) Assign VALUES(0) to the special variable NAME - OP_SETQS - name + [OP_SETQS + name] 3) Pop a value from the stack and assign it to the lexical variable in the N-th position. @@ -1699,8 +1684,7 @@ c_progv(cl_object args, int flags) { 4) Pop a value from the stack and assign it to the special variable denoted by NAME - OP_PSETQS - name + [OP_PSETQS + name] */ static int c_psetq(cl_object old_args, int flags) { @@ -1855,15 +1839,15 @@ c_tagbody(cl_object args, int flags) asm_op2(OP_TAGBODY, nt); tag_base = current_pc(); for (i = nt; i; i--) - asm1(Cnil); + asm_arg(0); for (body = args; !endp(body); body = CDR(body)) { label = CAR(body); item_type = type_of(label); if (item_type == t_symbol || item_type == t_fixnum || item_type == t_bignum) { - asm_at(tag_base, MAKE_FIXNUM(current_pc()-tag_base)); - tag_base++; + asm_complete(0, tag_base); + tag_base += OPARG_SIZE; } else { compile_form(label, FLAG_IGNORE); } @@ -1947,29 +1931,12 @@ c_values(cl_object args, int flags) { } -static int -c_when(cl_object form, int flags) { - cl_fixnum label; - - flags = maybe_values(flags); - - /* Compile test */ - compile_form(pop(&form), FLAG_VALUES); - label = asm_jmp(OP_JNIL); - - /* Compile body */ - flags = compile_body(form, flags); - asm_complete(OP_JNIL, label); - - return flags; -} - - static int compile_form(cl_object stmt, int flags) { compiler_record *l; cl_object function; bool push = flags & FLAG_PUSH; + int new_flags; /* FIXME! We should protect this region with error handling */ BEGIN: @@ -1977,9 +1944,9 @@ compile_form(cl_object stmt, int flags) { * First try with variable references and quoted constants */ if (ATOM(stmt)) { + cl_fixnum index; if (SYMBOLP(stmt) && stmt != Cnil) { cl_object stmt1 = c_macro_expand1(stmt); - cl_fixnum index; if (stmt1 != stmt) { stmt = stmt1; goto BEGIN; @@ -1988,23 +1955,18 @@ compile_form(cl_object stmt, int flags) { if (index >= 0) { asm_op2(push? OP_PUSHV : OP_VAR, index); } else { - asm_op(push? OP_PUSHVS : OP_VARS); - asm1(stmt); + asm_op2c(push? OP_PUSHVS : OP_VARS, stmt); } - goto OUTPUT; - } + } else QUOTED: - if (!(flags & FLAG_USEFUL)) - goto OUTPUT; - if (stmt == Cnil) { - asm_op(push? OP_PUSHNIL : OP_NIL); - goto OUTPUT; + if ((flags & FLAG_USEFUL)) { + if (stmt == Cnil) { + asm_op(push? OP_PUSHNIL : OP_NIL); + } else { + asm_op2c(push? OP_PUSHQ : OP_QUOTE, stmt); + } } - if (push) - asm_op(OP_PUSHQ); - else if (FIXNUMP(stmt)) - asm_op(OP_QUOTE); - asm1(stmt); + new_flags = flags; goto OUTPUT; } /* @@ -2022,11 +1984,8 @@ compile_form(cl_object stmt, int flags) { } for (l = database; l->symbol != OBJNULL; l++) if (l->symbol == function) { - int new_flags; c_env.lexical_level += l->lexical_increment; new_flags = (*(l->compiler))(CDR(stmt), flags); - if (push && !(new_flags & FLAG_PUSH)) - asm_op(OP_PUSH); goto OUTPUT; } /* @@ -2046,8 +2005,10 @@ for special form ~S.", 1, function); /* * Finally resort to ordinary function calls. */ - c_call(stmt, flags); + new_flags = c_call(stmt, flags); OUTPUT: + if (push && !(new_flags & FLAG_PUSH)) + asm_op(OP_PUSH); return flags; } @@ -2063,9 +2024,14 @@ compile_body(cl_object body, int flags) { asm_op(OP_HALT); VALUES(0) = Cnil; NValues = 0; - bytecodes = asm_end(handle, Cnil); - interpret(bytecodes->bytecodes.data); + bytecodes = asm_end(handle); + interpret(bytecodes, bytecodes->bytecodes.code); asm_clear(handle); +#ifdef GBC_BOEHM + GC_free(bytecodes->bytecodes.code); + GC_free(bytecodes->bytecodes.data); + GC_free(bytecodes); +#endif body = CDR(body); } } @@ -2374,22 +2340,22 @@ ILLEGAL_LAMBDA: FEprogram_error("LAMBDA: Illegal lambda list ~S.", 1, org_lambda_list); } -static void -c_default(cl_index deflt_pc) { - cl_object deflt = asm_ref(deflt_pc); +static cl_object +c_default(cl_fixnum base_pc, cl_object deflt) { cl_type t = type_of(deflt); if (((t == t_symbol) && (deflt->symbol.stype == stp_constant) && !FIXNUMP(SYM_VAL(deflt)))) { /* FIXME! Shouldn't this happen only in unsafe mode */ - asm_at(deflt_pc, SYM_VAL(deflt)); + deflt = SYM_VAL(deflt); } else if (CONSP(deflt) && (CAR(deflt) == @'quote') && !FIXNUMP(CADR(deflt))) { - asm_at(deflt_pc, CADR(deflt)); + deflt = CADR(deflt); } else if ((t == t_symbol) || (t == t_cons) || (t == t_fixnum)) { - cl_index pc = current_pc(); - asm_at(deflt_pc, MAKE_FIXNUM(pc-deflt_pc)); + cl_fixnum pc = current_pc()-base_pc; compile_form(deflt, FLAG_VALUES); asm_op(OP_EXIT); + deflt = MAKE_FIXNUM(pc); } + return deflt; } static void @@ -2412,12 +2378,13 @@ cl_object make_lambda(cl_object name, cl_object lambda) { cl_object reqs, opts, rest, key, keys, auxs, allow_other_keys; cl_object specials, doc, decl, body, output; - cl_index opts_pc, keys_pc, label; + cl_index label; int nopts, nkeys; cl_index handle; cl_compiler_env old_c_env = c_env; c_env.lexical_level++; + c_env.coalesce = 0; reqs = si_process_lambda(lambda); opts = VALUES(1); @@ -2437,58 +2404,59 @@ make_lambda(cl_object name, cl_object lambda) { if (Null(si_valid_function_name_p(name))) FEprogram_error("LAMBDA: Not a valid function name ~S",1,name); - asm_list(reqs); /* Special arguments */ + c_env.constants = reqs; /* Special arguments */ reqs = CDR(reqs); while (!endp(reqs)) { cl_object v = pop(&reqs); c_register_var2(v, &specials); } - opts_pc = current_pc()+1; /* Optional arguments */ - nopts = fix(CAR(opts)); - asm_list(opts); + nopts = fix(CAR(opts)); /* Optional arguments */ + c_env.constants = nconc(c_env.constants, opts); - asm1(rest); /* Name of &rest argument */ + asm_constant(rest); /* Name of &rest argument */ if (Null(key)) { - asm1(MAKE_FIXNUM(0)); /* &key was not supplied */ + asm_constant(MAKE_FIXNUM(0)); /* &key was not supplied */ nkeys = 0; } else { - asm1(allow_other_keys); /* Value of &allow-other-keys */ - keys_pc = current_pc()+1; /* Keyword arguments */ - nkeys = fix(CAR(keys)); - asm_list(keys); + asm_constant(allow_other_keys); /* Value of &allow-other-keys */ + nkeys = fix(CAR(keys)); /* Keyword arguments */ + c_env.constants = nconc(c_env.constants, keys); } - asm1(doc); - asm1(decl); + asm_constant(doc); + asm_constant(decl); label = asm_jmp(OP_JMP); + opts = CDR(opts); while (nopts--) { - c_default(opts_pc+1); - c_register_var2(asm_ref(opts_pc), &specials); - c_register_var2(asm_ref(opts_pc+2), &specials); - opts_pc+=3; + CADR(opts) = c_default(handle, CADR(opts)); + c_register_var2(CAR(opts), &specials); + c_register_var2(CADDR(opts), &specials); + opts = CDDDR(opts); } c_register_var2(rest, &specials); + keys = CDR(keys); while (nkeys--) { - c_default(keys_pc+2); - c_register_var2(asm_ref(keys_pc+1), &specials); - c_register_var2(asm_ref(keys_pc+3), &specials); - keys_pc+=4; + CADDR(keys) = c_default(handle, CADDR(keys)); + c_register_var2(CADR(keys), &specials); + c_register_var2(CADDDR(keys), &specials); + keys = CDDDDR(keys); } - + + c_env.coalesce = TRUE; + if (!Null(name)) c_register_block(si_function_block_name(name)); if ((current_pc() - label) == 1) - set_pc(label); + set_pc(handle); else asm_complete(OP_JMP, label); while (!endp(auxs)) { /* Local bindings */ cl_object var = pop(&auxs); cl_object value = pop(&auxs); - compile_form(value, FLAG_VALUES); c_bind(var, specials); } @@ -2496,7 +2464,7 @@ make_lambda(cl_object name, cl_object lambda) { compile_body(body, FLAG_VALUES); asm_op(OP_HALT); - output = asm_end(handle, Cnil); + output = asm_end(handle); output->bytecodes.name = name; output->bytecodes.specials = specials; output->bytecodes.definition = Null(SYM_VAL(@'si::*keep-definitions*'))? @@ -2548,7 +2516,7 @@ si_make_lambda(cl_object name, cl_object rest) } cl_object -eval(cl_object form, cl_object *new_bytecodes, cl_object env) +si_eval_with_env(cl_object form, cl_object env) { volatile cl_compiler_env old_c_env = c_env; volatile cl_index handle; @@ -2561,12 +2529,7 @@ eval(cl_object form, cl_object *new_bytecodes, cl_object env) compile_form(form, FLAG_VALUES); asm_op(OP_EXIT); asm_op(OP_HALT); - if (new_bytecodes == NULL) - bytecodes = asm_end(handle, Cnil); - else { - bytecodes = asm_end(handle, *new_bytecodes); - *new_bytecodes = bytecodes; - } + bytecodes = asm_end(handle); } CL_UNWIND_PROTECT_EXIT { #ifdef CL_COMP_OWN_STACK asm_clear(handle); @@ -2577,7 +2540,12 @@ eval(cl_object form, cl_object *new_bytecodes, cl_object env) lex_env = env; VALUES(0) = Cnil; NValues = 0; - interpret(bytecodes->bytecodes.data); + interpret(bytecodes, bytecodes->bytecodes.code); +#ifdef GBC_BOEHM + GC_free(bytecodes->bytecodes.code); + GC_free(bytecodes->bytecodes.data); + GC_free(bytecodes); +#endif ihs_pop(); return VALUES(0); } diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 838322e36..845e7dea8 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -16,11 +16,9 @@ #include "ecl-inl.h" #include "bytecodes.h" -#define next_code(v) (*(v++)) +static char *disassemble(cl_object bytecodes, char *vector); -static cl_object *disassemble(cl_object *vector); - -static cl_object *base = NULL; +static char *base = NULL; static void print_noarg(const char *s) { @@ -48,134 +46,124 @@ print_oparg_arg(const char *s, cl_fixnum n, cl_object x) { } static cl_object * -disassemble_vars(const char *message, cl_object *vector, cl_index step) { - cl_index n = fix(next_code(vector)); +disassemble_vars(const char *message, cl_object *data, cl_index step) { + cl_object o = *(data++); + cl_index n = fix(o); if (n) { terpri(Cnil); print_noarg(message); - for (; n; n--, vector+=step) { - prin1(vector[0], Cnil); + for (; n; n--, data+=step) { + prin1(data[0], Cnil); if (n > 1) print_noarg(", "); } } - return vector; + return data; } static void disassemble_lambda(cl_object bytecodes) { - cl_object *vector = bytecodes->bytecodes.data; + cl_object *data; + char *vector; /* Name of LAMBDA */ print_arg("\nName:\t\t", bytecodes->bytecodes.name); /* Print required arguments */ - vector = disassemble_vars("Required:\t", vector, 1); + data = bytecodes->bytecodes.data; + data = disassemble_vars("Required:\t", data, 1); /* Print optional arguments */ - vector = disassemble_vars("Optionals:\t", vector, 3); + data = disassemble_vars("Optionals:\t", data, 3); /* Print rest argument */ - if (vector[0] != Cnil) { - print_arg("\nRest:\t\t", vector[0]); + if (data[0] != Cnil) { + print_arg("\nRest:\t\t", data[0]); } - vector++; + data++; /* Print keyword arguments */ - if (vector[0] == MAKE_FIXNUM(0)) { - vector++; + if (data[0] == MAKE_FIXNUM(0)) { + data++; goto NO_KEYS; } - if (vector[0] != Cnil) { - print_arg("\nOther keys:\t", vector[0]); + if (data[0] != Cnil) { + print_arg("\nOther keys:\t", data[0]); } - vector++; - vector = disassemble_vars("Keywords:\t", vector, 4); + data++; + data = disassemble_vars("Keywords:\t", data, 4); NO_KEYS: /* Print aux arguments */ - print_arg("\nDocumentation:\t", next_code(vector)); - print_arg("\nDeclarations:\t", next_code(vector)); + print_arg("\nDocumentation:\t", *(data++)); + print_arg("\nDeclarations:\t", *(data++)); - base = vector; - while (vector[0] != MAKE_FIXNUM(OP_HALT)) - vector = disassemble(vector); -} - -/* -------------------- DISASSEMBLER AIDS -------------------- */ - -static inline cl_fixnum -get_oparg(cl_object o) { - return GET_OPARG(o); -} - -static inline cl_fixnum -packed_label(cl_object *v) { - return v + get_oparg(v[0]) - base; -} - -static inline cl_fixnum -simple_label(cl_object *v) { - return v + fix(v[0]) - base; + base = vector = bytecodes->bytecodes.code; + while (vector[0] != OP_HALT) + vector = disassemble(bytecodes, vector); } /* -------------------- DISASSEMBLER CORE -------------------- */ -/* OP_DOLIST label +/* OP_DOLIST labelz, labelo ... ; code to bind the local variable OP_EXIT ... ; code executed on each iteration OP_EXIT + labelo: ... ; code executed at the end OP_EXIT - label: + labelz: 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; +static char * +disassemble_dolist(cl_object bytecodes, char *vector) { + char *exit, *output; cl_object lex_old = lex_env; lex_copy(); - exit = packed_label(vector-1); - print_oparg("DOLIST\t", exit); - vector = disassemble(vector); + GET_LABEL(exit, vector); + GET_LABEL(output, vector); + print_oparg("DOLIST\t", exit-base); + vector = disassemble(bytecodes, vector); print_noarg("\t\t; dolist binding"); - vector = disassemble(vector); + vector = disassemble(bytecodes, vector); print_noarg("\t\t; dolist body"); - vector = disassemble(vector); + vector = disassemble(bytecodes, vector); print_noarg("\t\t; dolist"); lex_env = lex_old; return vector; } -/* OP_TIMES label +/* OP_TIMES labelz, labelo ... ; code to bind the local variable OP_EXIT ... ; code executed on each iteration OP_EXIT + labelo: ... ; code executed at the end OP_EXIT - label: + labelz: 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; +static char * +disassemble_dotimes(cl_object bytecodes, char *vector) { + char *exit, *output; cl_object lex_old = lex_env; lex_copy(); - exit = packed_label(vector-1); - print_oparg("DOTIMES\t", exit); - vector = disassemble(vector); + GET_LABEL(exit, vector); + GET_LABEL(output, vector); + print_oparg("DOTIMES\t", exit-base); + vector = disassemble(bytecodes, vector); print_noarg("\t\t; dotimes times"); - vector = disassemble(vector); + vector = disassemble(bytecodes, vector); print_noarg("\t\t; dotimes body"); - vector = disassemble(vector); + vector = disassemble(bytecodes, vector); print_noarg("\t\t; dotimes"); lex_env = lex_old; @@ -191,19 +179,19 @@ disassemble_dotimes(cl_object *vector) { Executes the enclosed code in a lexical enviroment extended with the functions "fun1" ... "funn". */ -static cl_object * -disassemble_flet(cl_object *vector) { +static char * +disassemble_flet(cl_object bytecodes, char *vector) { cl_object lex_old = lex_env; - cl_index nfun = get_oparg(vector[-1]); + cl_index nfun = GET_OPARG(vector); print_noarg("FLET"); lex_copy(); while (nfun--) { - cl_object fun = next_code(vector); + cl_object fun = GET_DATA(vector, bytecodes); print_noarg("\n\tFLET\t"); @prin1(1, fun->bytecodes.name); } - vector = disassemble(vector); + vector = disassemble(bytecodes, vector); print_noarg("\t\t; flet"); lex_env = lex_old; @@ -219,18 +207,18 @@ disassemble_flet(cl_object *vector) { Executes the enclosed code in a lexical enviroment extended with the functions "fun1" ... "funn". */ -static cl_object * -disassemble_labels(cl_object *vector) { +static char * +disassemble_labels(cl_object bytecodes, char *vector) { cl_object lex_old = lex_env; - cl_index nfun = get_oparg(vector[-1]); + cl_index nfun = GET_OPARG(vector); print_noarg("LABELS"); lex_copy(); while (nfun--) { - cl_object fun = next_code(vector); + cl_object fun = GET_DATA(vector, bytecodes); print_arg("\n\tLABELS\t", fun->bytecodes.name); } - vector = disassemble(vector); + vector = disassemble(bytecodes, vector); print_noarg("\t\t; labels"); lex_env = lex_old; @@ -238,35 +226,37 @@ disassemble_labels(cl_object *vector) { } /* OP_MSETQ n{arg} - {fixnumn}|{symboln} + {fixnumn} ... - {fixnum1}|{symbol1} + {fixnum1} 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. + while special variables are denoted with a negative index X, which + denotes the value -1-X in the table of constants. */ -static cl_object * -disassemble_msetq(cl_object *vector) +static char * +disassemble_msetq(cl_object bytecodes, char *vector) { - int i, n = get_oparg(vector[-1]); + int i, n = GET_OPARG(vector); bool newline = FALSE; for (i=0; i= 0) { cl_format(4, Ct, make_constant_string("MSETQ\t~D,VALUES(~D)"), - var, MAKE_FIXNUM(i)); + MAKE_FIXNUM(var), MAKE_FIXNUM(i)); } else { + cl_object name = bytecodes->bytecodes.data[-1-var]; cl_format(4, Ct, make_constant_string("MSETQS\t~A,VALUES(~D)"), - var, MAKE_FIXNUM(i)); + name, MAKE_FIXNUM(i)); } } return vector; @@ -279,19 +269,17 @@ disassemble_msetq(cl_object *vector) 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) { +static char * +disassemble_progv(cl_object bytecodes, char *vector) { print_noarg("PROGV"); - vector = disassemble(vector); + vector = disassemble(bytecodes, vector); print_noarg("\t\t; progv"); return vector; } /* OP_TAGBODY n{arg} - tag1 label1 ... - tagn labeln label1: ... @@ -301,64 +289,55 @@ labeln: High level construct for the TAGBODY form. */ -static cl_object * -disassemble_tagbody(cl_object *vector) { - cl_index i, ntags = get_oparg(vector[-1]); +static char * +disassemble_tagbody(cl_object bytecodes, char *vector) { + cl_index i, ntags = GET_OPARG(vector); cl_object lex_old = lex_env; + char *destination; lex_copy(); print_noarg("TAGBODY"); - for (i=0; ibytecodes.size, aet_object); - vector->vector.self.t = b->bytecodes.data; + vector = cl_alloc_simple_vector(b->bytecodes.code_size, aet_fix); + vector->vector.self.fix = b->bytecodes.code; @(return b->bytecodes.lex vector) } diff --git a/src/c/eval.d b/src/c/eval.d index 7c81a43ae..ce9efcb92 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -226,17 +226,11 @@ si_unlink_symbol(cl_object s) cl_object cl_eval(cl_object form) { - return eval(form, NULL, Cnil); + return si_eval_with_env(form, Cnil); } cl_object -si_eval_with_env(cl_object form, cl_object env) -{ - return eval(form, NULL, env); -} - -cl_object -cl_safe_eval(cl_object form, cl_object *new_bytecodes, cl_object env, cl_object err_value) +cl_safe_eval(cl_object form, cl_object env, cl_object err_value) { cl_object output; @@ -244,7 +238,7 @@ cl_safe_eval(cl_object form, cl_object *new_bytecodes, cl_object env, cl_object output = err_value; } else { bds_bind(@'si::*ignore-errors*', Ct); - output = eval(form, new_bytecodes, env); + output = si_eval_with_env(form, env); bds_unwind1; } frs_pop(); @@ -253,7 +247,7 @@ cl_safe_eval(cl_object form, cl_object *new_bytecodes, cl_object env, cl_object @(defun si::safe-eval (form &optional (err_value @'error') env) @ - return cl_safe_eval(form, NULL, env, err_value); + return cl_safe_eval(form, env, err_value); @) @(defun constantp (arg &optional env) diff --git a/src/c/gbc.d b/src/c/gbc.d index fd0d2f305..ea1f4225e 100644 --- a/src/c/gbc.d +++ b/src/c/gbc.d @@ -339,10 +339,12 @@ BEGIN: case t_bytecodes: { cl_index i, size; - size = x->bytecodes.size; mark_object(x->bytecodes.name); mark_object(x->bytecodes.lex); mark_object(x->bytecodes.specials); + size = x->bytecodes.code_size; + mark_contblock(x->bytecodes.code, size); + size = x->bytecodes.data_size; mark_contblock(x->bytecodes.data, size * sizeof(cl_object)); for (i=0; ibytecodes.data[i]); diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 70de8be41..746d120c0 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -17,7 +17,6 @@ #include "ecl-inl.h" #include "bytecodes.h" -#define next_code(v) *(v++) #undef frs_pop #define frs_pop() { cl_stack_top = cl_stack + frs_top->frs_sp; frs_top--; } @@ -226,23 +225,23 @@ lambda_bind_var(cl_object var, cl_object val, cl_object specials) bind_special(var, val); } -static cl_object * -lambda_bind(int narg, cl_object lambda_list, cl_index sp) +static void +lambda_bind(int narg, cl_object lambda, cl_index sp) { - cl_object *data = lambda_list->bytecodes.data; - cl_object specials = lambda_list->bytecodes.specials; + cl_object *data = lambda->bytecodes.data; + cl_object specials = lambda->bytecodes.specials; int i, n; bool check_remaining = TRUE; /* 1) REQUIRED ARGUMENTS: N var1 ... varN */ - n = fix(next_code(data)); + n = fix(*(data++)); if (narg < n) - FEwrong_num_arguments(lambda_list->bytecodes.name); + FEwrong_num_arguments(lambda->bytecodes.name); for (; n; n--, narg--) - lambda_bind_var(next_code(data), cl_stack[sp++], specials); + lambda_bind_var(*(data++), cl_stack[sp++], specials); /* 2) OPTIONAL ARGUMENTS: N var1 value1 flag1 ... varN valueN flagN */ - for (n = fix(next_code(data)); n; n--, data+=3) { + for (n = fix(*(data++)); n; n--, data+=3) { if (narg) { lambda_bind_var(data[0], cl_stack[sp], specials); sp++; narg--; @@ -251,7 +250,7 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp) } else { cl_object defaults = data[1]; if (FIXNUMP(defaults)) { - interpret(&data[1] + fix(defaults)); + interpret(lambda, lambda->bytecodes.code + fix(defaults)); defaults = VALUES(0); } lambda_bind_var(data[0], defaults, specials); @@ -275,19 +274,21 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp) data++; if (narg && check_remaining) FEprogram_error("LAMBDA: Too many arguments to function ~S.", 1, - lambda_list->bytecodes.name); + lambda->bytecodes.name); } else { /* * Only when ALLOW-OTHER-KEYS /= 0, we process this: * 5) KEYWORDS: N key1 var1 value1 flag1 ... keyN varN valueN flagN */ - bool allow_other_keys = !Null(next_code(data)); + bool allow_other_keys = !Null(*(data++)); bool allow_other_keys_found = allow_other_keys; - int n = fix(next_code(data)); + int n = fix(*(data++)); cl_object *keys; cl_object spp[n]; bool other_found = FALSE; void *unbound = spp; /* not a valid lisp object */ + if ((narg & 1) != 0) + FEprogram_error("Function called with odd number of keyword arguments.", 0); for (i=0; ibytecodes.name); + 1, lambda->bytecodes.name); for (i=0; ibytecodes.code + fix(defaults)); defaults = VALUES(0); } lambda_bind_var(data[1],defaults,specials); @@ -332,14 +333,13 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp) lambda_bind_var(data[3],(spp[i] != unbound)? Ct : Cnil,specials); } } - return data; } cl_object lambda_apply(int narg, cl_object fun) { cl_index args = cl_stack_index() - narg; - cl_object name, *body; + cl_object name; bds_ptr old_bds_top; struct ihs_frame ihs; @@ -352,20 +352,20 @@ lambda_apply(int narg, cl_object fun) old_bds_top = bds_top; /* Establish bindings */ - body = lambda_bind(narg, fun, args); + lambda_bind(narg, fun, args); /* If it is a named lambda, set a block for RETURN-FROM */ VALUES(0) = Cnil; NValues = 0; name = fun->bytecodes.name; if (Null(name)) - interpret(body); + interpret(fun, fun->bytecodes.code); else { /* Accept (SETF name) */ if (CONSP(name)) name = CADR(name); CL_BLOCK_BEGIN(id) { bind_block(name, id); - interpret(body); + interpret(fun, fun->bytecodes.code); } CL_BLOCK_END; } bds_unwind(old_bds_top); @@ -376,21 +376,6 @@ lambda_apply(int narg, cl_object fun) /* -------------------- AIDS TO THE INTERPRETER -------------------- */ -static inline cl_fixnum -get_oparg(cl_object o) { - return GET_OPARG(o); -} - -static inline cl_object * -packed_label(cl_object *v) { - return v + GET_OPARG(v[0]); -} - -static inline cl_object * -simple_label(cl_object *v) { - return v + fix(v[0]); -} - static cl_object search_global(register cl_object s) { cl_object x = SYM_VAL(s); @@ -398,7 +383,7 @@ search_global(register cl_object s) { FEunbound_variable(s); return x; } - + /* Similar to funcall(), but registers calls in the IHS stack. */ static cl_object @@ -471,45 +456,46 @@ interpret_funcall(int narg, cl_object fun) { /* -------------------- THE INTERPRETER -------------------- */ -/* OP_DOLIST label +/* OP_DOLIST labelz, labelo ... ; code to bind the local variable OP_EXIT ... ; code executed on each iteration OP_EXIT + labelo: ... ; code executed at the end OP_EXIT - label: + labelz: 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 *volatile exit = packed_label(vector - 1); +static char * +interpret_dolist(cl_object bytecodes, char *vector) { + char *volatile exit; + char *output; + + GET_LABEL(exit, vector); + GET_LABEL(output, vector); /* 1) Set NIL block */ CL_BLOCK_BEGIN(id) { - cl_object *output; - cl_object list; + cl_object list = VALUES(0); bind_block(Cnil, id); - list = VALUES(0); - exit = packed_label(vector - 1); /* 2) Build list & bind variable*/ - vector = interpret(vector); - output = packed_label(vector-1); + vector = interpret(bytecodes, vector); /* 3) Repeat until list is exahusted */ while (!endp(list)) { NValues = 1; VALUES(0) = CAR(list); - interpret(vector); + interpret(bytecodes, vector); list = CDR(list); } VALUES(0) = Cnil; NValues = 1; - interpret(output); + interpret(bytecodes, output); /* 4) Restore environment */ lex_env = frs_top->frs_lex; @@ -518,49 +504,53 @@ interpret_dolist(cl_object *vector) { return exit; } -/* OP_TIMES label +/* OP_TIMES labelz, labelo ... ; code to bind the local variable OP_EXIT ... ; code executed on each iteration OP_EXIT + labelo: ... ; code executed at the end OP_EXIT - label: + labelz: 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 *volatile exit = packed_label(vector - 1); +static char * +interpret_dotimes(cl_object bytecodes, char *vector) { + char *volatile exit; + char *output; + + GET_LABEL(exit, vector); + GET_LABEL(output, vector); + CL_BLOCK_BEGIN(id) { - cl_object *output, length = VALUES(0); + cl_object length = VALUES(0); /* 1) Set up a nil block */ bind_block(Cnil, id); /* 2) Retrieve number and bind variables */ - exit = packed_label(vector - 1); - vector = interpret(vector); - output = packed_label(vector-1); + vector = interpret(bytecodes, vector); if (FIXNUMP(length)) { cl_fixnum i, l = fix(length); /* 3) Loop while needed */ for (i = 0; i < l;) { - interpret(vector); + interpret(bytecodes, vector); NValues = 1; VALUES(0) = MAKE_FIXNUM(++i); } } else { cl_object i = MAKE_FIXNUM(0); while (number_compare(i, length) < 0) { - interpret(vector); + interpret(bytecodes, vector); NValues = 1; VALUES(0) = i = one_plus(i); } } - interpret(output); + interpret(bytecodes, output); /* 4) Restore environment */ lex_env = frs_top->frs_lex; @@ -587,9 +577,9 @@ close_around(cl_object fun, cl_object lex) { 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]); +static char * +interpret_flet(cl_object bytecodes, char *vector) { + cl_index nfun = GET_OPARG(vector); /* 1) Copy the environment so that functions get it without references to themselves. */ @@ -597,7 +587,7 @@ interpret_flet(cl_object *vector) { /* 3) Add new closures to environment */ while (nfun--) { - cl_object fun = next_code(vector); + cl_object fun = GET_DATA(vector, bytecodes); cl_object f = close_around(fun,lex); bind_function(f->bytecodes.name, f); } @@ -614,14 +604,14 @@ interpret_flet(cl_object *vector) { 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]); +static char * +interpret_labels(cl_object bytecodes, char *vector) { + cl_index i, nfun = GET_OPARG(vector); cl_object l; /* 1) Build up a new environment with all functions */ for (i=0; ibytecodes.name, f); } @@ -635,30 +625,32 @@ interpret_labels(cl_object *vector) { } /* OP_MSETQ n{arg} - {fixnumn}|{symboln} + {fixnumn} ... - {fixnum1}|{symbol1} + {fixnum1} 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. + while special variables are denoted with a negative index X, which + denotes the value -1-X in the table of constants. */ -static cl_object * -interpret_msetq(cl_object *vector) +static char * +interpret_msetq(cl_object bytecodes, char *vector) { cl_object var, value; - int i, n = get_oparg(vector[-1]); + int i, n = GET_OPARG(vector); for (i=0; i= 0) + setq_local(var, value); else { - if (var->symbol.stype == stp_constant) - FEassignment_to_constant(var); + cl_object name = bytecodes->bytecodes.data[-1-var]; + if (name->symbol.stype == stp_constant) + FEassignment_to_constant(name); else - SYM_VAL(var) = value; + SYM_VAL(name) = value; } } if (NValues > 1) NValues = 1; @@ -671,8 +663,8 @@ interpret_msetq(cl_object *vector) 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) { +static char * +interpret_progv(cl_object bytecodes, char *vector) { cl_object values = VALUES(0); cl_object vars = cl_stack_pop(); @@ -690,7 +682,7 @@ interpret_progv(cl_object *vector) { } vars = CDR(vars); } - vector = interpret(vector); + vector = interpret(bytecodes, vector); /* 3) Restore environment */ lex_env = old_lex_env; @@ -698,25 +690,16 @@ interpret_progv(cl_object *vector) { return vector; } -cl_object * -interpret(cl_object *vector) { - cl_type t; - cl_object s; +char * +interpret(cl_object bytecodes, char *vector) { BEGIN: - s = next_code(vector); - t = type_of(s); - if (t != t_fixnum) { - VALUES(0) = s; - NValues = 1; - goto BEGIN; - } - switch (GET_OP(s)) { + switch (GET_OPCODE(vector)) { /* OP_QUOTE Sets VALUES(0) to an immediate value. */ case OP_QUOTE: - VALUES(0) = next_code(vector); + VALUES(0) = GET_DATA(vector, bytecodes); NValues = 1; break; @@ -725,7 +708,7 @@ interpret(cl_object *vector) { VAR is the name of the variable for readability purposes. */ case OP_VAR: { - int lex_env_index = get_oparg(s); + int lex_env_index = GET_OPARG(vector); VALUES(0) = search_local(lex_env_index); NValues = 1; break; @@ -736,7 +719,7 @@ interpret(cl_object *vector) { VAR should be either a special variable or a constant. */ case OP_VARS: { - cl_object var_name = next_code(vector); + cl_object var_name = GET_DATA(vector, bytecodes); VALUES(0) = search_global(var_name); NValues = 1; break; @@ -753,7 +736,7 @@ interpret(cl_object *vector) { Pushes the value of the n-th local onto the stack. */ case OP_PUSHV: { - int lex_env_index = get_oparg(s); + int lex_env_index = GET_OPARG(vector); cl_stack_push(search_local(lex_env_index)); break; } @@ -763,7 +746,7 @@ interpret(cl_object *vector) { VAR should be either a special variable or a constant. */ case OP_PUSHVS: { - cl_object var_name = next_code(vector); + cl_object var_name = GET_DATA(vector, bytecodes); cl_stack_push(search_global(var_name)); break; } @@ -772,30 +755,16 @@ interpret(cl_object *vector) { Pushes "value" onto the stack. */ case OP_PUSHQ: - cl_stack_push(next_code(vector)); + cl_stack_push(GET_DATA(vector, bytecodes)); break; - /* 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: { - cl_fixnum n = get_oparg(s); - cl_object fun = next_code(vector); - if (fun->symbol.gfdef == OBJNULL || fun->symbol.mflag) - FEundefined_function(fun); - VALUES(0) = interpret_funcall(n, fun->symbol.gfdef); - break; - } - /* OP_CALL 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_CALL: { - cl_fixnum n = get_oparg(s); + cl_fixnum n = GET_OPARG(vector); cl_object fun = VALUES(0); VALUES(0) = interpret_funcall(n, fun); break; @@ -807,7 +776,7 @@ interpret(cl_object *vector) { are left in VALUES(...) */ case OP_FCALL: { - cl_fixnum n = get_oparg(s); + cl_fixnum n = GET_OPARG(vector); cl_object fun = cl_stack_top[-n-1]; VALUES(0) = interpret_funcall(n, fun); cl_stack_pop(); @@ -826,28 +795,13 @@ interpret(cl_object *vector) { 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); - if (fun->symbol.gfdef == OBJNULL) - FEundefined_function(fun); - VALUES(0) = interpret_funcall(n, fun->symbol.gfdef); - cl_stack_push(VALUES(0)); - break; - } - /* OP_PCALL 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_PCALL: { - cl_fixnum n = get_oparg(s); + cl_fixnum n = GET_OPARG(vector); cl_object fun = VALUES(0); VALUES(0) = interpret_funcall(n, fun); cl_stack_push(VALUES(0)); @@ -860,7 +814,7 @@ interpret(cl_object *vector) { is pushed on the stack. */ case OP_PFCALL: { - cl_fixnum n = get_oparg(s); + cl_fixnum n = GET_OPARG(vector); cl_object fun = cl_stack_top[-n-1]; VALUES(0) = interpret_funcall(n, fun); cl_stack_top[-1] = VALUES(0); @@ -879,10 +833,10 @@ interpret(cl_object *vector) { case OP_HALT: return vector-1; case OP_FLET: - vector = interpret_flet(vector); + vector = interpret_flet(bytecodes, vector); break; case OP_LABELS: - vector = interpret_labels(vector); + vector = interpret_labels(bytecodes, vector); break; /* OP_LFUNCTION n{arg}, function-name{symbol} @@ -890,7 +844,7 @@ interpret(cl_object *vector) { which have been deposited in the stack. */ case OP_LFUNCTION: { - int lex_env_index = get_oparg(s); + int lex_env_index = GET_OPARG(vector); cl_object fun_record = search_local(lex_env_index); cl_object fun_object = CDR(fun_record); VALUES(0) = fun_object; @@ -904,7 +858,7 @@ interpret(cl_object *vector) { environment. This last value takes precedence. */ case OP_FUNCTION: - VALUES(0) = ecl_fdefinition(next_code(vector)); + VALUES(0) = ecl_fdefinition(GET_DATA(vector, bytecodes)); NValues = 1; break; @@ -914,19 +868,20 @@ interpret(cl_object *vector) { environment. This last value takes precedence. */ case OP_CLOSE: { - cl_object function_object = next_code(vector); + cl_object function_object = GET_DATA(vector, bytecodes); VALUES(0) = close_around(function_object, lex_env); NValues = 1; break; } - /* OP_GO n{arg}, tag-name{symbol} + /* OP_GO n{arg} + OP_QUOTE 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_name = next_code(vector); - cl_object id = search_local(get_oparg(s)); + cl_object id = search_local(GET_OPARG(vector)); + cl_object tag_name = GET_DATA(vector, bytecodes); VALUES(0) = Cnil; NValues = 0; cl_go(id, tag_name); @@ -937,7 +892,7 @@ interpret(cl_object *vector) { occuppies the n-th position. */ case OP_RETURN: { - int lex_env_index = get_oparg(s); + int lex_env_index = GET_OPARG(vector); cl_object block_record = search_local(lex_env_index); cl_object block_name = CAR(block_record); cl_object id = CDR(block_record); @@ -957,30 +912,44 @@ interpret(cl_object *vector) { /* OP_JMP label{arg} OP_JNIL label{arg} OP_JT label{arg} - OP_JEQ label{arg}, value{object} - OP_JNEQ label{arg}, value{object} + OP_JEQ value{object}, label{arg} + OP_JNEQ value{object}, label{arg} 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); + case OP_JMP: { + cl_oparg jump = GET_OPARG(vector); + vector += jump - OPARG_SIZE; break; - case OP_JNIL: + } + case OP_JNIL: { + cl_oparg jump = GET_OPARG(vector); NValues = 1; - if (Null(VALUES(0))) vector = vector - 1 + get_oparg(s); + if (Null(VALUES(0))) + vector += jump - OPARG_SIZE; break; - case OP_JT: + } + case OP_JT: { + cl_oparg jump = GET_OPARG(vector); NValues = 1; - if (!Null(VALUES(0))) vector = vector - 1 + get_oparg(s); + if (!Null(VALUES(0))) + vector += jump - OPARG_SIZE; break; - case OP_JEQL: - if (eql(VALUES(0), next_code(vector))) - vector = vector + get_oparg(s) - 2; + } + case OP_JEQL: { + cl_oparg value = GET_OPARG(vector); + cl_oparg jump = GET_OPARG(vector); + if (eql(VALUES(0), bytecodes->bytecodes.data[value])) + vector += jump - OPARG_SIZE; break; - case OP_JNEQL: - if (!eql(VALUES(0), next_code(vector))) - vector = vector + get_oparg(s) - 2; + } + case OP_JNEQL: { + cl_oparg value = GET_OPARG(vector); + cl_oparg jump = GET_OPARG(vector); + if (!eql(VALUES(0), bytecodes->bytecodes.data[value])) + vector += jump - OPARG_SIZE; break; + } case OP_NOT: VALUES(0) = (VALUES(0) == Cnil)? Ct : Cnil; NValues = 1; @@ -989,7 +958,7 @@ interpret(cl_object *vector) { Undo "n" local bindings. */ case OP_UNBIND: { - cl_index n = get_oparg(s); + cl_index n = GET_OPARG(vector); while (n--) lex_env = CDDR(lex_env); break; @@ -998,7 +967,7 @@ interpret(cl_object *vector) { Undo "n" bindings of special variables. */ case OP_UNBINDS: { - cl_index n = get_oparg(s); + cl_index n = GET_OPARG(vector); bds_unwind_n(n); break; } @@ -1010,39 +979,39 @@ interpret(cl_object *vector) { value of VALUES(0) or the first value of the stack. */ case OP_BIND: { - cl_object var_name = next_code(vector); + cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = VALUES(0); bind_var(var_name, value); break; } case OP_PBIND: { - cl_object var_name = next_code(vector); + cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = cl_stack_pop(); bind_var(var_name, value); break; } case OP_VBIND: { - int n = get_oparg(s); - cl_object var_name = next_code(vector); + int n = GET_OPARG(vector); + cl_object var_name = GET_DATA(vector, bytecodes); 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 var_name = GET_DATA(vector, bytecodes); cl_object value = VALUES(0); bind_special(var_name, value); break; } case OP_PBINDS: { - cl_object var_name = next_code(vector); + cl_object var_name = GET_DATA(vector, bytecodes); 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); + int n = GET_OPARG(vector); + cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = (n < NValues) ? VALUES(n) : Cnil; bind_special(var_name, value); break; @@ -1056,13 +1025,13 @@ interpret(cl_object *vector) { first value on the stack (OP_PSETQ[S]). */ case OP_SETQ: { - int lex_env_index = get_oparg(s); + int lex_env_index = GET_OPARG(vector); setq_local(lex_env_index, VALUES(0)); NValues = 1; break; } case OP_SETQS: { - cl_object var = next_code(vector); + cl_object var = GET_DATA(vector, bytecodes); if (var->symbol.stype == stp_constant) FEassignment_to_constant(var); else @@ -1071,14 +1040,14 @@ interpret(cl_object *vector) { break; } case OP_PSETQ: { - int lex_env_index = get_oparg(s); + int lex_env_index = GET_OPARG(vector); setq_local(lex_env_index, cl_stack_pop()); Values[0] = Cnil; NValues = 1; break; } case OP_PSETQS: { - cl_object var = next_code(vector); + cl_object var = GET_DATA(vector, bytecodes); if (var->symbol.stype == stp_constant) FEassignment_to_constant(var); else @@ -1088,7 +1057,7 @@ interpret(cl_object *vector) { break; } - /* OP_BLOCK label{arg}, block-name{symbol} + /* OP_BLOCK label{arg} ... OP_EXIT label: @@ -1097,14 +1066,19 @@ interpret(cl_object *vector) { LABEL points to the first instruction after OP_EXIT. */ case OP_BLOCK: { + cl_object name; cl_object id = new_frame_id(); - cl_stack_push(packed_label(vector - 1)); + char *exit; + /* FIXME! */ + GET_LABEL(exit, vector); + cl_stack_push((cl_object)exit); + name = GET_DATA(vector, bytecodes); if (frs_push(FRS_CATCH, id) == 0) { - bind_block(next_code(vector), id); + bind_block(name, id); } else { lex_env = frs_top->frs_lex; frs_pop(); - vector = cl_stack_pop(); + vector = (char *)cl_stack_pop(); } break; } @@ -1116,14 +1090,18 @@ interpret(cl_object *vector) { High level construct for the DO and BLOCK forms. */ case OP_DO: { + cl_object name = Cnil; cl_object id = new_frame_id(); - cl_stack_push(packed_label(vector - 1)); + char *exit; + /* FIXME! */ + GET_LABEL(exit, vector); + cl_stack_push((cl_object)exit); if (frs_push(FRS_CATCH, id) == 0) { - bind_block(Cnil, id); + bind_block(name, id); } else { lex_env = frs_top->frs_lex; frs_pop(); - vector = cl_stack_pop(); + vector = (char *)cl_stack_pop(); /* FIXME! */ } break; } @@ -1135,14 +1113,17 @@ interpret(cl_object *vector) { Sets a catch point using the tag in VALUES(0). LABEL points to the first instruction after the end (OP_EXIT) of the block */ - case OP_CATCH: - cl_stack_push(packed_label(vector - 1)); + case OP_CATCH: { + char *exit; + GET_LABEL(exit, vector); + cl_stack_push((cl_object)exit); if (frs_push(FRS_CATCH, VALUES(0)) != 0) { lex_env = frs_top->frs_lex; frs_pop(); - vector = cl_stack_pop(); + vector = (char *)cl_stack_pop(); /* FIXME! */ } break; + } /* OP_TAGBODY n{arg} label1 ... @@ -1156,20 +1137,22 @@ interpret(cl_object *vector) { High level construct for the TAGBODY form. */ case OP_TAGBODY: { + int n = GET_OPARG(vector); /* Here we save the location of the jump table */ - cl_stack_push(vector); + cl_stack_push((cl_object)vector); /* FIXME! */ if (frs_push(FRS_CATCH, bind_tagbody()) == 0) { /* The first time, we "name" the tagbody and * skip the jump table */ - vector += get_oparg(s); + vector += n * OPARG_SIZE; } else { /* Wait here for gotos. Each goto sets VALUES(0) to an integer which ranges from 0 to ntags-1, depending on the tag. These numbers are indices into the jump table and are computed at compile time. */ - cl_object *table = (cl_object*)cl_stack_top[-1]; - vector = simple_label(table + fix(VALUES(0))); + char *table = (char *)cl_stack_top[-1]; + table = table + fix(VALUES(0)) * OPARG_SIZE; + vector = table + *(cl_oparg *)table; lex_env = frs_top->frs_lex; } break; @@ -1196,16 +1179,16 @@ interpret(cl_object *vector) { cl_stack_pop(); break; case OP_DOLIST: - vector = interpret_dolist(vector); + vector = interpret_dolist(bytecodes, vector); break; case OP_DOTIMES: - vector = interpret_dotimes(vector); + vector = interpret_dotimes(bytecodes, vector); break; case OP_MSETQ: - vector = interpret_msetq(vector); + vector = interpret_msetq(bytecodes, vector); break; case OP_PROGV: - vector = interpret_progv(vector); + vector = interpret_progv(bytecodes, vector); break; /* OP_PUSHVALUES Pushes the values output by the last form, plus the number @@ -1249,7 +1232,7 @@ interpret(cl_object *vector) { Pop N values from the stack and store them in VALUES(...) */ case OP_VALUES: { - cl_fixnum n = get_oparg(s); + cl_fixnum n = GET_OPARG(vector); NValues = n; while (n) VALUES(--n) = cl_stack_pop(); @@ -1281,16 +1264,19 @@ interpret(cl_object *vector) { is always executed, even if a THROW, RETURN or GO happen within the first piece of code. */ - case OP_PROTECT: - cl_stack_push(packed_label(vector - 1)); + case OP_PROTECT: { + char *exit; + GET_LABEL(exit, vector); + cl_stack_push((cl_object)exit); if (frs_push(FRS_PROTECT,Cnil) != 0) { lex_env = frs_top->frs_lex; frs_pop(); - vector = cl_stack_pop(); + vector = (char *)cl_stack_pop(); cl_stack_push(MAKE_FIXNUM(nlj_fr - frs_top)); goto PUSH_VALUES; } break; + } case OP_PROTECT_NORMAL: bds_unwind(frs_top->frs_bds_top); lex_env = frs_top->frs_lex; diff --git a/src/c/load.d b/src/c/load.d index 775503421..c00d83740 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -94,11 +94,10 @@ si_load_source(cl_object source, cl_object verbose, cl_object print) } CL_UNWIND_PROTECT_BEGIN { for (;;) { - cl_object bytecodes = Cnil; x = cl_read(3, strm, Cnil, OBJNULL); if (x == OBJNULL) break; - eval(x, &bytecodes, Cnil); + si_eval_with_env(x, Cnil); if (print != Cnil) { @write(1, x); @terpri(0); diff --git a/src/c/macros.d b/src/c/macros.d index a401e2eea..e6003a97e 100644 --- a/src/c/macros.d +++ b/src/c/macros.d @@ -127,8 +127,54 @@ macro_expand(cl_object form, cl_object env) return new_form; } +static cl_object +or_macro(cl_object whole, cl_object env) +{ + cl_object output = Cnil; + whole = CDR(whole); + if (Null(whole)) /* (OR) => NIL */ + @(return Cnil); + while (!Null(CDR(whole))) { + output = CONS(CONS(CAR(whole), Cnil), output); + whole = CDR(whole); + } + if (Null(output)) /* (OR form1) => form1 */ + @(return CAR(whole)); + /* (OR form1 ... formn forml) => (COND (form1) ... (formn) (t forml)) */ + output = CONS(cl_list(2, Ct, CAR(whole)), output); + @(return CONS(@'cond', cl_nreverse(output))) +} + +static cl_object +expand_and(cl_object whole) +{ + if (Null(whole)) + return Ct; + if (Null(CDR(whole))) + return CAR(whole); + return cl_list(3, @'if', CAR(whole), expand_and(CDR(whole))); +} + +static cl_object +and_macro(cl_object whole, cl_object env) +{ + @(return expand_and(CDR(whole))) +} + +static cl_object +when_macro(cl_object whole, cl_object env) +{ + cl_object args = CDR(whole); + if (endp(args)) + FEprogram_error("Syntax error: ~S.", 1, whole); + return cl_list(3, @'if', CAR(args), CONS(@'progn', CDR(args))); +} + void init_macros(void) { SYM_VAL(@'*macroexpand-hook*') = @'funcall'; + cl_def_c_macro(@'or', or_macro); + cl_def_c_macro(@'and', and_macro); + cl_def_c_macro(@'when', when_macro); } diff --git a/src/c/read.d b/src/c/read.d index 27aae6792..384ee18ba 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -861,7 +861,7 @@ sharp_dot_reader(cl_object in, cl_object c, cl_object d) in = read_object(in); if (read_suppress) @(return Cnil) - in = eval(in, NULL, Cnil); + in = si_eval_with_env(in, Cnil); @(return in) } @@ -1855,7 +1855,7 @@ read_VV(cl_object block, void *entry) */ (*entry_point)(block); len = block->cblock.data_size; -#ifdef GBC_BOEHM +#ifdef ECL_DYNAMIC_VV VV = block->cblock.data = len? (cl_object *)cl_alloc(len * sizeof(cl_object)) : NULL; #else VV = block->cblock.data; diff --git a/src/c/tclBasic.d b/src/c/tclBasic.d index 9afda4198..258ca2c09 100644 --- a/src/c/tclBasic.d +++ b/src/c/tclBasic.d @@ -62,7 +62,7 @@ eval_from_string(char *s) cl_object x; STRING_INPUT_STREAM(s, strm); x = @read(3, (cl_object)&strm, Cnil, OBJNULL); - return (x != OBJNULL) ? eval(x, NULL, Cnil) : Cnil; + return (x != OBJNULL) ? si_eval_with_env(x, Cnil) : Cnil; } static cl_object string_stream; diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 27d96ec3a..db12dc03c 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -644,8 +644,6 @@ (cmperr "Defmacro-lambda-list contains illegal use of ~s." key)) (defun c2dm (name whole env vl body) - (when (or *safe-compile* *compiler-check-args*) - (wt-nl "check_arg(2);")) (let ((lcl (next-lcl))) (when whole (check-vref whole) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index bc8c8e17a..0cc1bc057 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -117,14 +117,16 @@ (wt-nl "cl_object value0;") (wt-nl "if (!FIXNUMP(flag)){") (wt-nl "Cblock=flag;") - #-boehm-gc + (wt-nl "#ifndef ECL_DYNAMIC_VV") (wt-nl "flag->cblock.data = VV;") + (wt-nl "#endif") (wt-nl "flag->cblock.data_size = VM;") (wt-nl "flag->cblock.data_text = compiler_data_text;") (wt-nl "flag->cblock.data_text_size = compiler_data_text_size;") (wt-nl "return;}") - #+boehm-gc + (wt-nl "#ifdef ECL_DYNAMIC_VV") (wt-nl "VV = Cblock->cblock.data;") + (wt-nl "#endif") ;; useless in initialization. (dolist (form *top-level-forms*) (let ((*compile-to-linking-call* nil) @@ -143,12 +145,13 @@ (incf *next-vv*) (wt-h "#define VM" vv-reservation " " *next-vv*) (wt-h "#define VM " *next-vv*) - #+boehm-gc + (wt-h "#ifdef ECL_DYNAMIC_VV") (wt-h "static cl_object *VV;") - #-boehm-gc + (wt-h "#else") (if (zerop *next-vv*) (wt-h "static cl_object VV[1];") (wt-h "static cl_object VV[VM];")) + (wt-h "#endif") (when *linking-calls* (dotimes (i (length *linking-calls*)) (declare (fixnum i)) @@ -575,7 +578,7 @@ (wt-nl "si_put_sysprop(" vv "," (add-symbol 'si::pretty-print-format) "," ppn ");") (wt-nl))) (wt-h "static cl_object L" cfun "();") - (wt-nl "cl_def_c_macro_va(" vv ",(cl_objectfn)L" cfun ");")) + (wt-nl "cl_def_c_macro(" vv ",L" cfun ");")) (defun t3defmacro (fname cfun macro-lambda ppn sp &aux (*lcl* 0) (*temp* 0) (*max-temp* 0) @@ -587,7 +590,7 @@ (*destination* 'RETURN) (*reservation-cmacro* (next-cmacro))) (wt-comment "macro definition for " fname) - (wt-nl1 "static cl_object L" cfun "(int narg, cl_object V1, cl_object V2)") + (wt-nl1 "static cl_object L" cfun "(cl_object V1, cl_object V2)") (wt-nl1 "{") (wt-function-prolog sp) (c2dm fname (car macro-lambda) (second macro-lambda) (third macro-lambda) diff --git a/src/doc/help.lsp b/src/doc/help.lsp index 6986bf033..22655a562 100644 --- a/src/doc/help.lsp +++ b/src/doc/help.lsp @@ -335,6 +335,11 @@ Returns T if CHAR is alphabetic; NIL otherwise.") (docfun alphanumericp function (char) " Returns T if CHAR is either numeric or alphabetic; NIL otherwise.") +(docfun and macro "(and {form}*)" " +Evaluates FORMs in order. If any FORM evaluates to NIL, returns +immediately with the value NIL. Otherwise, returns all values of the +last FORM.") + (docfun append function (&rest lists) " Constructs and returns a new list by concatenating the args.") @@ -2314,6 +2319,11 @@ while PORT is an integer identifies the port number to which to connect. This function returns a two-way stream which can be used in any of the stream operations.") +(docfun or macro "(or {form}*)" " +Evaluates FORMs in order from left to right. If any FORM evaluates to non- +NIL, quits and returns that (single) value. If the last FORM is reached, +returns whatever values it returns.") + (docfun output-stream-p function (stream) " Returns T if STREAM can handle output operations; NIL otherwise.") @@ -3286,6 +3296,10 @@ being the N-th value.") (docfun vectorp function (x) " Returns T if X is a vector; NIL otherwise.") +(docfun when macro "(when test {form}*)" " +If TEST evaluates to non-NIL, then evaluates FORMs and returns all values of +the last FORM. If not, simply returns NIL.") + (docfun write function (object &key (stream *standard-output*) (escape *print-escape*) (radix *print-radix*) (base *print-base*) (circle *print-circle*) (pretty *print-pretty*) diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index b86a1b061..9aca9e37d 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -184,8 +184,23 @@ enum { OP_OPCODE_SHIFT = 7 }; -#define OPARG_SHIFT 16 -#define MAX_OPARG (1 << (31 - OPARG_SHIFT) - 1) -#define SET_OPARG(o,n) ((cl_object)((cl_fixnum)(o) | ((n) << OPARG_SHIFT))) -#define GET_OPARG(o) ((cl_fixnum)(o) >> OPARG_SHIFT) -#define GET_OP(o) (((cl_fixnum)(o) & 0xFF) >> 2) +/* + If we we working with character pointers, + typedef char cl_opcode; + ... + #define OPCODE_SIZE sizeof(cl_opcode) + #define OPARG_SIZE sizeof(cl_oparg) + but since we are not... + */ +#define MAX_OPARG 0x7FFF +typedef char cl_opcode; +typedef int16_t cl_oparg; +#define OPCODE_SIZE 1 +#define OPARG_SIZE sizeof(cl_oparg) +#define READ_OPCODE(v) (*(cl_opcode *)(v)) +#define READ_OPARG(v) (*(cl_oparg *)(v)) +#define GET_OPCODE(v) (*((cl_opcode *)(v))++) +#define GET_OPARG(v) (*((cl_oparg *)(v))++) +#define GET_DATA(v,b) (b->bytecodes.data[*((cl_oparg *)(v))++]) +#define GET_LABEL(pc,v) {pc = (v) + *(cl_oparg *)v; v += OPARG_SIZE;} + diff --git a/src/h/external.h b/src/h/external.h index 1b70985cf..15ea3ae23 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -152,7 +152,7 @@ extern cl_object cl_make_cfun(cl_object (*self)(), cl_object name, cl_object blo extern cl_object cl_make_cfun_va(cl_object (*self)(int narg,...), cl_object name, cl_object block); extern cl_object cl_make_cclosure_va(cl_object (*self)(int narg,...), cl_object env, cl_object block); extern void cl_def_c_function(cl_object sym, cl_object (*self)(), int narg); -extern void cl_def_c_macro_va(cl_object sym, cl_object (*self)(int narg,...)); +extern void cl_def_c_macro(cl_object sym, cl_object (*self)(cl_object, cl_object)); extern void cl_def_c_function_va(cl_object sym, cl_object (*self)(int narg,...)); @@ -237,7 +237,7 @@ extern cl_object si_valid_function_name_p(cl_object name); extern cl_object si_process_declarations _ARGS((int narg, cl_object body, ...)); extern cl_object make_lambda(cl_object name, cl_object lambda); -extern cl_object eval(cl_object form, cl_object *bytecodes, cl_object env); +extern cl_object si_eval_with_env(cl_object form, cl_object env); /* interpreter.c */ @@ -257,7 +257,7 @@ extern void cl_stack_pop_values(int n); extern cl_object lex_env; extern cl_object lambda_apply(int narg, cl_object fun); -extern cl_object *interpret(cl_object *memory); +extern char *interpret(cl_object bytecodes, char *pc); /* disassembler.c */ @@ -308,13 +308,12 @@ extern cl_object cl_va_arg(cl_va_list args); extern cl_object si_unlink_symbol(cl_object s); extern cl_object cl_eval(cl_object form); -extern cl_object si_eval_with_env(cl_object form, cl_object env); extern cl_object cl_constantp(int narg, cl_object arg, ...); #define funcall cl_funcall extern cl_object cl_apply_from_stack(cl_index narg, cl_object fun); extern cl_object link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args); -extern cl_object cl_safe_eval(cl_object form, cl_object *bytecodes, cl_object env, cl_object err_value); +extern cl_object cl_safe_eval(cl_object form, cl_object env, cl_object err_value); /* ffi.c */ diff --git a/src/h/internal.h b/src/h/internal.h index 6b9d768bf..686beb9cd 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -76,6 +76,10 @@ extern const struct { short type; } all_functions[]; +/* alloc.d/alloc_2.d */ + +extern cl_object ecl_alloc_bytecodes(cl_index data_size, cl_index code_size); + /* file.d */ /* diff --git a/src/h/object.h b/src/h/object.h index e6d68a019..a3c24e7e2 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -360,9 +360,11 @@ struct bytecodes { cl_object name; /* function name */ cl_object lex; /* lexical environment */ cl_object specials; /* list of special variables */ - cl_index size; /* number of bytecodes */ - cl_object *data; /* the intermediate language */ cl_object definition; /* function definition in list form */ + cl_index code_size; /* number of bytecodes */ + cl_index data_size; /* number of constants */ + char *code; /* the intermediate language */ + cl_object *data; /* non-inmediate constants used in the code */ }; struct cfun { /* compiled function header */ diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index c9a0cad7b..271f8d041 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -120,38 +120,6 @@ as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." ;;; dolist), some not at all (e.g. defun). ;;; Thus their names need not be exported. -(defmacro and (&rest forms) - "Syntax: (and {form}*) -Evaluates FORMs in order. If any FORM evaluates to NIL, returns -immediately with the value NIL. Otherwise, returns all values of the -last FORM." - (if (endp forms) - T - (do* ((res '(NIL)) - (insert res (cddar (rplaca insert `(IF ,(car fs) NIL)))) - (fs forms (cdr fs))) - ((endp (cdr fs)) - (rplaca insert (car fs)) - (car res)))) - ) - -(defmacro or (&rest forms) - "Syntax: (or {form}*) -Evaluates FORMs in order from left to right. If any FORM evaluates to non- -NIL, quits and returns that (single) value. If the last FORM is reached, -returns whatever values it returns." - (if (endp forms) - nil - (let ((x (reverse forms))) - (do ((forms (cdr x) (cdr forms)) - (form (car x) - (let ((temp (gensym))) - `(LET ((,temp ,(car forms))) -; (DECLARE (:READ-ONLY ,temp)) ; Beppe - (IF ,temp ,temp ,form))))) - ((endp forms) form)))) - ) - (defmacro loop (&rest body &aux (tag (gensym))) "Syntax: (loop {form}*) Establishes a NIL block and executes FORMs repeatedly. The loop is normally @@ -208,12 +176,6 @@ TESTs evaluates to non-NIL." `(IF ,(car l) (PROGN ,@(cdr l)) ,form)))))) ) -(defmacro when (pred &rest body) - "Syntax: (when test {form}*) -If TEST evaluates to non-NIL, then evaluates FORMs and returns all values of -the last FORM. If not, simply returns NIL." - `(IF ,pred (PROGN ,@body))) - (defmacro unless (pred &rest body) "Syntax: (unless test {form}*) If TEST evaluates to NIL, then evaluates FORMs and returns all values of the