diff --git a/src/c/all_functions.d b/src/c/all_functions.d index a3b9a47d8..a9eb72982 100644 --- a/src/c/all_functions.d +++ b/src/c/all_functions.d @@ -712,6 +712,8 @@ const struct function_info all_functions[] = { {"IHS-TOP", siLihs_top, si}, {"IHS-FUN", siLihs_fun, si}, {"IHS-ENV", siLihs_env, si}, + {"IHS-NEXT", siLihs_next, si}, + {"IHS-PREV", siLihs_prev, si}, {"FRS-TOP", siLfrs_top, si}, {"FRS-BDS", siLfrs_bds, si}, {"FRS-CLASS", siLfrs_class, si}, diff --git a/src/c/compiler.d b/src/c/compiler.d index 568c47d16..c0cb7d692 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -33,25 +33,41 @@ cl_object @'&aux'; cl_object @':allow-other-keys'; -cl_object bytecodes; -int lexical_level; +typedef struct { + cl_object variables; + cl_object macros; + cl_fixnum lexical_level; +#ifdef CL_COMP_OWN_STACK + cl_object bytecodes; +#endif +} cl_compiler_env; + +static cl_compiler_env c_env; /********************* PRIVATE ********************/ -static cl_index asm_begin(void); -static cl_object asm_end(cl_index); -static void asm_clear(cl_index); -static void asm_grow(void); -static void asm1(register cl_object op); -static void asm_op(register int n); -static void asm_list(register cl_object l); -static void asmn(int narg, ...); -static void asm_at(register cl_index where, register cl_object what); -static cl_index asm_jmp(register int op); -static void asm_complete(register int op, register cl_index original); +#ifdef CL_COMP_OWN_STACK static cl_index current_pc(); 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); +#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 +#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 cl_index asm_jmp(register int op); +static void asm_complete(register int op, register cl_index original); static void c_and(cl_object args); static void c_block(cl_object args); @@ -123,6 +139,17 @@ pop_maybe_nil(cl_object *l) { /* ------------------------------ ASSEMBLER ------------------------------ */ +#ifdef CL_COMP_OWN_STACK +static cl_object +alloc_bytecodes() +{ + cl_object vector = alloc_simple_vector(128, aet_object); + array_allocself(vector); + vector->vector.hasfillp = TRUE; + vector->vector.fillp = 0; + return vector; +} + static cl_index asm_begin(void) { /* Save beginning of bytecodes for this session */ @@ -133,51 +160,82 @@ static void asm_clear(cl_index beginning) { cl_index i; /* Remove data from this session */ - bytecodes->vector.fillp = beginning; + c_env.bytecodes->vector.fillp = beginning; +} + +static void +asm_grow(void) { + cl_object *old_data = c_env.bytecodes->vector.self.t; + cl_index old_size = c_env.bytecodes->vector.fillp; + c_env.bytecodes->vector.dim += 128; + array_allocself(c_env.bytecodes); + memcpy(c_env.bytecodes->vector.self.t, old_data, old_size*sizeof(cl_object)); +} + +static void +asm1(register cl_object 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.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; +} + +static void +set_pc(cl_index pc) { + c_env.bytecodes->vector.fillp = pc; } static cl_object -asm_end(cl_index beginning) { +asm_ref(register cl_index n) { + return c_env.bytecodes->vector.self.t[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, i; /* Save bytecodes from this session in a new vector */ length = current_pc() - beginning; bytes = length * sizeof(cl_object); - new_bytecodes = alloc_object(t_bytecodes); + if (!Null(bytecodes)) + new_bytecodes = bytecodes; + else { + new_bytecodes = alloc_object(t_bytecodes); + new_bytecodes->bytecodes.size = 0; + } new_bytecodes->bytecodes.lex = Cnil; - new_bytecodes->bytecodes.data = alloc(bytes); - new_bytecodes->bytecodes.size = length; + if (new_bytecodes->bytecodes.size < length) { + new_bytecodes->bytecodes.data = alloc(bytes); + new_bytecodes->bytecodes.size = length; + } +#ifdef CL_COMP_OWN_STACK memcpy(new_bytecodes->bytecodes.data, - &bytecodes->vector.self.t[beginning], + &c_env.bytecodes->vector.self.t[beginning], bytes); - +#else + memcpy(new_bytecodes->bytecodes.data, + &cl_stack[beginning], + bytes); +#endif asm_clear(beginning); return new_bytecodes; } -static void -asm_grow(void) { - cl_object *old_data = bytecodes->vector.self.t; - cl_index old_size = bytecodes->vector.fillp; - bytecodes->vector.dim += 128; - array_allocself(bytecodes); - memcpy(bytecodes->vector.self.t, old_data, old_size*sizeof(cl_object)); -} - -static void -asm1(register cl_object op) { - int where = bytecodes->vector.fillp; - if (where >= bytecodes->vector.dim) - asm_grow(); - bytecodes->vector.self.t[where] = op; - bytecodes->vector.fillp++; -} - -static void -asm_op(register int n) { - asm1(MAKE_FIXNUM(n)); -} static void asm_op2(register int code, register cl_fixnum n) { @@ -189,34 +247,6 @@ asm_op2(register int code, register cl_fixnum n) { asm1(new_op); } -static inline cl_object -make_op(int code) { - return MAKE_FIXNUM(code); -} - -static cl_object -make_op2(int code, cl_fixnum n) { - cl_object volatile op = MAKE_FIXNUM(code); - cl_object new_op = SET_OPARG(op, n); - if (n < -MAX_OPARG || MAX_OPARG < n) - FEprogram_error("Argument to bytecode is too large", 0); - return new_op; -} - -static void -asm_insert(cl_fixnum where, cl_object op) { - cl_fixnum end = bytecodes->vector.fillp; - if (where > end) - FEprogram_error("asm1_insert: position out of range", 0); - if (end >= bytecodes->vector.dim) - asm_grow(); - memmove(&bytecodes->vector.self.t[where+1], - &bytecodes->vector.self.t[where], - (end - where) * sizeof(cl_object)); - bytecodes->vector.fillp++; - bytecodes->vector.self.t[where] = op; -} - static void asm_list(register cl_object l) { if (ATOM(l)) @@ -227,30 +257,6 @@ asm_list(register cl_object l) { } } -static void -asmn(int narg, ...) { - va_list args; - - va_start(args, narg); - while (narg-- > 0) - asm1(va_arg(args, cl_object)); -} - -static void -asm_at(register cl_index where, register cl_object what) { - if (where > bytecodes->vector.fillp) - FEprogram_error("Internal error at asm_at()",0); - bytecodes->vector.self.t[where] = what; -} - -static cl_index -asm_block(void) { - cl_index output; - output = current_pc(); - asm1(MAKE_FIXNUM(0)); - return output; -} - static cl_index asm_jmp(register int op) { cl_index output = current_pc(); @@ -271,21 +277,6 @@ asm_complete(register int op, register cl_index original) { asm_at(original, new_code); } -static cl_index -current_pc(void) { - return bytecodes->vector.fillp; -} - -static void -set_pc(cl_index pc) { - bytecodes->vector.fillp = pc; -} - -static cl_object -asm_ref(register cl_index n) { - return bytecodes->vector.self.t[n]; -} - /* ------------------------------ COMPILER ------------------------------ */ typedef struct { @@ -352,10 +343,62 @@ FEill_formed_input() FEprogram_error("Unproper list handled to the compiler.", 0); } +static void +c_new_env() +{ + c_env.variables = Cnil; + c_env.macros = Cnil; + c_env.lexical_level = 0; +} + +static cl_object +c_macro_expand1(cl_object stmt) +{ + return macro_expand1(stmt, CONS(c_env.variables, c_env.macros)); +} + +void +c_register_symbol_macro(cl_object name, cl_object exp_fun) +{ + c_env.variables = CONS(list(3, name, @'si::symbol-macro', exp_fun), + c_env.variables); +} + +void +c_register_macro(cl_object name, cl_object exp_fun) +{ + c_env.macros = CONS(list(3, name, @'macro', exp_fun), c_env.macros); +} + static void c_register_var(register cl_object var, bool special) { - CAR(lex_env) = CONS(CONS(var, special? @'special' : Cnil), CAR(lex_env)); + c_env.variables = CONS(list(2, var, special? @'special' : Cnil), + c_env.variables); +} + +static cl_fixnum +c_var_ref(cl_object var) +{ + cl_fixnum n = 0; + cl_object l; + for (l = c_env.variables; CONSP(l); l = CDR(l)) { + cl_object record = CAR(l); + cl_object name = CAR(record); + cl_object special = CADR(record); + if (name != var) { + /* Symbol not yet found. Only count locals. */ + n++; + } else if (special == @'si::symbol-macro') { + /* We should never get here. The variable should have + been macro expanded. */ + FEerror("Internal error: symbol macro ~S used as variable", + 1, var); + } else { + return Null(special)? n : -1; + } + } + return -1; } static bool @@ -397,13 +440,13 @@ c_bind(cl_object var, cl_object specials) static void compile_setq(int op, cl_object var) { - cl_object ndx; + cl_fixnum ndx; if (!SYMBOLP(var)) FEillegal_variable_name(var); - ndx = lex_var_sch(var); - if (!Null(ndx) && CDR(ndx) != @'special') - asm_op(op); /* Lexical variable */ + ndx = c_var_ref(var); + if (ndx >= 0) + asm_op2(op, ndx); /* Lexical variable */ else if (var->symbol.stype == stp_constant) FEassignment_to_constant(var); else if (op == OP_SETQ) @@ -688,8 +731,7 @@ c_do_doa(int op, cl_object args) { cl_object bindings, test, specials, body, l; cl_object stepping = Cnil, vars = Cnil; cl_index labelb, labelt, labelz; - cl_object lex_old = lex_env; - lex_copy(); + cl_object old_variables = c_env.variables; bindings = pop(&args); test = pop(&args); @@ -767,7 +809,7 @@ c_do_doa(int op, cl_object args) { /* Compile return point of block */ asm_complete(OP_DO, labelz); - lex_env = lex_old; + c_env.variables = old_variables; } @@ -809,8 +851,7 @@ c_dolist_dotimes(int op, cl_object args) { cl_object list = pop(&head); cl_object specials, body; cl_index labelz, labelo; - cl_object lex_old = lex_env; - lex_copy(); + cl_object old_variables = c_env.variables; @si::process-declarations(1, args); body = VALUES(1); @@ -848,7 +889,7 @@ c_dolist_dotimes(int op, cl_object args) { /* Exit point for block */ asm_complete(op, labelz); - lex_env = lex_old; + c_env.variables = old_variables; } @@ -889,8 +930,6 @@ static void c_labels_flet(int op, cl_object args) { cl_object def_list = pop(&args); int nfun = length(def_list); - cl_object lex_old = lex_env; - lex_copy(); /* Remove declarations */ @si::process-declarations(1, args); @@ -907,8 +946,6 @@ c_labels_flet(int op, cl_object args) { } while (!endp(def_list)); compile_body(args); asm_op(OP_EXIT); - - lex_env = lex_old; } @@ -1037,8 +1074,7 @@ c_labels(cl_object args) { static void c_let_leta(int op, cl_object args) { cl_object bindings, specials, body, l, vars; - cl_object lex_old = lex_env; - lex_copy(); + cl_object old_variables = c_env.variables; bindings = car(args); @si::process-declarations(1, CDR(args)); @@ -1080,7 +1116,7 @@ c_let_leta(int op, cl_object args) { compile_body(body); asm_op(OP_EXIT); - lex_env = lex_old; + c_env.variables = old_variables; } static void @@ -1114,8 +1150,7 @@ c_macrolet(cl_object args) { cl_object def_list, def, name; int nfun = 0; - cl_object lex_old = lex_env; - lex_copy(); + cl_object old_macros = c_env.macros; /* Pop the list of definitions */ for (def_list = pop(&args); !endp(def_list); ) { @@ -1126,10 +1161,10 @@ c_macrolet(cl_object args) macro = funcall(4, @'si::expand-defmacro', name, arglist, definition); function = make_lambda(name, CDR(macro)); - lex_macro_bind(name, function); + c_register_macro(name, function); } compile_body(args); - lex_env = lex_old; + c_env.macros = old_macros; } @@ -1138,8 +1173,7 @@ c_multiple_value_bind(cl_object args) { cl_object vars, value, body, specials; cl_index save_pc, n; - cl_object lex_old = lex_env; - lex_copy(); + cl_object old_variables = c_env.variables; vars = pop(&args); value = pop(&args); @@ -1168,7 +1202,7 @@ c_multiple_value_bind(cl_object args) compile_body(body); asm_op(OP_EXIT); } - lex_env = lex_old; + c_env.variables = old_variables; } @@ -1217,7 +1251,7 @@ c_multiple_value_setq(cl_object args) { cl_object aux, v = pop(&orig_vars); if (!SYMBOLP(v)) FEillegal_variable_name(v); - v = macro_expand1(v, lex_env); + v = c_macro_expand1(v); if (!SYMBOLP(v)) { aux = v; v = @gensym(0); @@ -1250,11 +1284,12 @@ c_multiple_value_setq(cl_object args) { asm_op2(OP_MSETQ, nvars); vars = reverse(vars); while (nvars--) { - cl_object ndx, var = pop(&vars); + cl_object var = pop(&vars); + cl_fixnum ndx; if (!SYMBOLP(var)) FEillegal_variable_name(var); - ndx = lex_var_sch(var); - if (!Null(ndx) && CDR(ndx) != @'special') + ndx = c_var_ref(var); + if (ndx >= 0) asm1(var); /* Lexical variable */ else if (var->symbol.stype == stp_constant) FEassignment_to_constant(var); @@ -1291,7 +1326,7 @@ c_nth_value(cl_object args) { static void c_or(cl_object args) { if (Null(args)) { - asm1(Cnil); + compile_form(Cnil, FALSE); return; } else if (ATOM(args)) { FEill_formed_input(); @@ -1376,7 +1411,7 @@ c_psetq(cl_object old_args) { cl_object value = pop(&old_args); if (!SYMBOLP(var)) FEillegal_variable_name(var); - var = macro_expand1(var, lex_env); + var = c_macro_expand1(var); if (!SYMBOLP(var)) use_psetf = TRUE; args = CONS(var, CONS(value, args)); @@ -1439,7 +1474,7 @@ c_setq(cl_object args) { cl_object value = pop(&args); if (!SYMBOLP(var)) FEillegal_variable_name(var); - var = macro_expand1(var, lex_env); + var = c_macro_expand1(var); if (SYMBOLP(var)) { compile_form(value, FALSE); compile_setq(OP_SETQ, var); @@ -1454,13 +1489,9 @@ static void c_symbol_macrolet(cl_object args) { cl_object def_list, def, name, specials, body; - cl_object lex_old = lex_env; + cl_object old_variables = c_env.variables; int nfun = 0; - /* Set a new lexical environment where we will bind - our macrology */ - lex_copy(); - def_list = pop(&args); @si::process-declarations(1,args); body = VALUES(1); @@ -1478,10 +1509,10 @@ c_symbol_macrolet(cl_object args) declared special and appear in a symbol-macrolet.", 1, name); definition = list(2, arglist, list(2, @'quote', expansion)); function = make_lambda(name, definition); - lex_symbol_macro_bind(name, function); + c_register_symbol_macro(name, function); } compile_body(body); - lex_env = lex_old; + c_env.variables = old_variables; } static void @@ -1490,7 +1521,7 @@ c_tagbody(cl_object args) cl_fixnum tag_base; cl_object label, body; enum type item_type; - int nt; + int nt, i; /* count the tags */ for (nt = 0, body = args; !endp(body); body = CDR(body)) { @@ -1508,7 +1539,8 @@ c_tagbody(cl_object args) } asm_op2(OP_TAGBODY, nt); tag_base = current_pc(); - set_pc(tag_base + 2 * nt); + for (i = 2*nt; i; i--) + asm1(Cnil); for (body = args; !endp(body); body = CDR(body)) { label = CAR(body); @@ -1559,7 +1591,7 @@ c_unless(cl_object form) { asm_complete(OP_JT, label_true); /* When test failed, output NIL */ - asm1(Cnil); + compile_form(Cnil, FALSE); asm_complete(OP_JMP, label_false); } @@ -1623,19 +1655,25 @@ compile_form(cl_object stmt, bool push) { */ if (ATOM(stmt)) { if (SYMBOLP(stmt)) { - cl_object stmt1 = macro_expand1(stmt, lex_env); + cl_object stmt1 = c_macro_expand1(stmt); + cl_fixnum index; if (stmt1 != stmt) { stmt = stmt1; goto BEGIN; } - if (push) asm_op(OP_PUSHV); + index = c_var_ref(stmt); + if (index >= 0) { + asm_op2(push? OP_PUSHV : OP_VAR, index); + } else { + asm_op(push? OP_PUSHVS : OP_VARS); + } asm1(stmt); goto OUTPUT; } QUOTED: if (push) asm_op(OP_PUSHQ); - else if (FIXNUMP(stmt) || SYMBOLP(stmt)) + else if (FIXNUMP(stmt)) asm_op(OP_QUOTE); asm1(stmt); goto OUTPUT; @@ -1660,7 +1698,7 @@ compile_form(cl_object stmt, bool push) { } for (l = database; l->symbol != OBJNULL; l++) if (l->symbol == function) { - lexical_level += l->lexical_increment; + c_env.lexical_level += l->lexical_increment; (*(l->compiler))(CDR(stmt)); if (push) asm_op(OP_PUSH); goto OUTPUT; @@ -1669,7 +1707,7 @@ compile_form(cl_object stmt, bool push) { * Next try to macroexpand */ { - cl_object new_stmt = macro_expand1(stmt, lex_env); + cl_object new_stmt = c_macro_expand1(stmt); if (new_stmt != stmt){ stmt = new_stmt; goto BEGIN; @@ -1689,15 +1727,17 @@ for special form ~S.", 1, function); static void compile_body(cl_object body) { - if (lexical_level == 0 && !endp(body)) { + if (c_env.lexical_level == 0 && !endp(body)) { while (!endp(CDR(body))) { cl_index handle = asm_begin(); + cl_object bytecodes; compile_form(CAR(body), FALSE); asm_op(OP_EXIT); asm_op(OP_HALT); VALUES(0) = Cnil; NValues = 0; - interpret(&bytecodes->vector.self.t[handle]); + bytecodes = asm_end(handle, Cnil); + interpret(bytecodes->bytecodes.data); asm_clear(handle); body = CDR(body); } @@ -2011,11 +2051,9 @@ make_lambda(cl_object name, cl_object lambda) { cl_index specials_pc, opts_pc, keys_pc, label; int nopts, nkeys; cl_index handle; - cl_object lex_old = lex_env; - int old_lexical_level = lexical_level; + cl_compiler_env old_c_env = c_env; - lex_copy(); - lexical_level++; + c_env.lexical_level++; reqs = @si::process-lambda-list(1,lambda); opts = VALUES(1); @@ -2052,7 +2090,8 @@ make_lambda(cl_object name, cl_object lambda) { keys_pc = current_pc()+1; /* Keyword arguments */ nkeys = fix(CAR(keys)); asm_list(keys); - asmn(2, doc, decl); + asm1(doc); + asm1(decl); label = asm_jmp(OP_JMP); @@ -2085,84 +2124,67 @@ make_lambda(cl_object name, cl_object lambda) { compile_body(body); asm_op(OP_HALT); - lexical_level = old_lexical_level; - lex_env = lex_old; + c_env = old_c_env; - return asm_end(handle); -} - -static cl_object -alloc_bytecodes() -{ - cl_object vector = alloc_simple_vector(128, aet_object); - array_allocself(vector); - vector->vector.hasfillp = TRUE; - vector->vector.fillp = 0; - return vector; + return asm_end(handle, Cnil); } @(defun si::make_lambda (name rest) - cl_object lambda, old_bytecodes = bytecodes; - cl_object lex_old = lex_env; + cl_object lambda; + cl_compiler_env old_c_env = c_env; @ - lex_new(); + c_new_env(); if (frs_push(FRS_PROTECT, Cnil)) { - lex_env = lex_old; - bytecodes = old_bytecodes; + c_env = old_c_env; frs_pop(); unwind(nlj_fr, nlj_tag); } - bytecodes = alloc_bytecodes(); lambda = make_lambda(name,rest); frs_pop(); - bytecodes = old_bytecodes; - lex_env = lex_old; + c_env = old_c_env; @(return lambda) @) cl_object eval(cl_object form, cl_object *new_bytecodes, cl_object env) { - cl_object old_bytecodes = bytecodes; - int old_lexical_level = lexical_level; - cl_object lex_old = lex_env; + cl_compiler_env old_c_env = c_env; + cl_object bytecodes, lex_old = lex_env; cl_index handle; bool unwinding; - if (new_bytecodes == NULL) - bytecodes = alloc_bytecodes(); - else if (*new_bytecodes != Cnil) { - bytecodes = *new_bytecodes; - } else { - bytecodes = *new_bytecodes = alloc_bytecodes(); - } + c_new_env(); if (Null(env)) { lex_new(); - lexical_level = 0; + c_env.lexical_level = 0; } else { - lexical_level = 1; + c_env.lexical_level = 1; lex_env = env; lex_copy(); } + handle = asm_begin(); if (frs_push(FRS_PROTECT, Cnil)) { + asm_clear(handle); lex_env = lex_old; - bytecodes = old_bytecodes; - lexical_level = old_lexical_level; + c_env = old_c_env; frs_pop(); unwind(nlj_fr, nlj_tag); } - handle = asm_begin(); compile_form(form, FALSE); asm_op(OP_EXIT); asm_op(OP_HALT); VALUES(0) = Cnil; NValues = 0; - interpret(&bytecodes->vector.self.t[handle]); - asm_clear(handle); + if (new_bytecodes == NULL) + bytecodes = asm_end(handle, Cnil); + else { + bytecodes = asm_end(handle, *new_bytecodes); + *new_bytecodes = bytecodes; + } + interpret(bytecodes->bytecodes.data); frs_pop(); lex_env = lex_old; - bytecodes = old_bytecodes; - lexical_level = old_lexical_level; + c_env = old_c_env; return VALUES(0); } @@ -2171,8 +2193,12 @@ init_compiler(void) { compiler_record *l; - register_root(&bytecodes); - + register_root(&c_env.variables); + register_root(&c_env.macros); +#ifdef CL_COMP_OWN_STACK + register_root(&c_env.bytecodes); + c_env.bytecodes = alloc_bytecodes(); +#endif for (l = database; l->name[0] != 0; l++) l->symbol = _intern(l->name, lisp_package); } diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 477cf4318..02b8f8b23 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -368,24 +368,21 @@ disassemble(cl_object *vector) { } switch (GET_OP(s)) { case OP_PUSHQ: printf("PUSH\t'"); - @prin1(1, next_code(vector)); + @prin1(1,next_code(vector)); break; - case OP_PUSH: string = "PUSH\tVALUES(0)"; - goto NOARG; - case OP_PUSHV: string = "PUSHV"; - s = search_symbol(next_code(vector)); - goto ARG; + 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"; - s = next_code(vector); + QUOTE: s = next_code(vector); goto ARG; - case OP_NOP: string = "NOP"; - goto NOARG; + case OP_NOP: string = "NOP"; 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_PUSHVALUES: string = "PUSH\tVALUES"; goto NOARG; + case OP_MCALL: string = "MCALL"; goto NOARG; case OP_CALL: string = "CALL"; n = get_oparg(s); s = next_code(vector); @@ -422,8 +419,7 @@ disassemble(cl_object *vector) { case OP_RETURN: string = "RETFROM"; s = next_code(vector); goto ARG; - case OP_THROW: string = "THROW"; - goto NOARG; + case OP_THROW: string = "THROW"; goto NOARG; case OP_JMP: string = "JMP"; n = packed_label(vector-1); goto OPARG; @@ -441,18 +437,16 @@ disassemble(cl_object *vector) { s = next_code(vector); n = packed_label(vector-2); goto OPARG_ARG; - case OP_BIND: string = "BIND"; goto SETQ; - case OP_BINDS: string = "BINDS"; goto SETQS; - case OP_PBIND: string = "PBIND"; goto SETQ; - case OP_PBINDS: string = "PBINDS"; goto SETQS; + 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 SETQS; + case OP_PSETQS: string = "PSETQS"; goto QUOTE; case OP_SETQ: string = "SETQ"; SETQ: s = next_code(vector); goto ARG; - case OP_SETQS: string = "SETQS"; - SETQS: s = next_code(vector); - goto ARG; + case OP_SETQS: string = "SETQS"; goto QUOTE; case OP_MSETQ: vector = disassemble_msetq(vector); break; case OP_MBIND: vector = disassemble_mbind(vector); @@ -466,8 +460,7 @@ disassemble(cl_object *vector) { case OP_VALUES: string = "VALUES"; n = get_oparg(s); goto OPARG; - case OP_NTHVAL: string = "NTHVAL"; - goto NOARG; + case OP_NTHVAL: string = "NTHVAL"; goto NOARG; case OP_DOLIST: vector = disassemble_dolist(vector); break; case OP_DOTIMES: vector = disassemble_dotimes(vector); diff --git a/src/c/format.d b/src/c/format.d index b7974edcd..8c33e27f2 100644 --- a/src/c/format.d +++ b/src/c/format.d @@ -73,7 +73,7 @@ static cl_object fmt_stream; static int ctl_origin; static int ctl_index; static int ctl_end; -static cl_object *fmt_base; +static cl_index fmt_base; static int fmt_index; static int fmt_end; static int *fmt_jmp_buf; @@ -98,7 +98,7 @@ static int fmt_line_length; volatile int old_ctl_origin; \ volatile int old_ctl_index; \ volatile int old_ctl_end; \ - cl_object * volatile old_fmt_base; \ + volatile cl_index old_fmt_base; \ volatile int old_fmt_index; \ volatile int old_fmt_end; \ int * volatile old_fmt_jmp_buf; \ @@ -196,7 +196,14 @@ fmt_advance(void) { if (fmt_index >= fmt_end) fmt_error("arguments exhausted"); - return(fmt_base[fmt_index++]); + return(cl_stack[fmt_index++]); +} + +static cl_object +fmt_push_list(cl_object l) +{ + for (; !endp(l); l = CDR(l)) + cl_stack_push(CAR(l)); } static int @@ -677,7 +684,7 @@ fmt_plural(bool colon, bool atsign) { fmt_max_param(0); if (colon) { - if (fmt_index == 0) + if (fmt_index == fmt_base) fmt_error("can't back up"); --fmt_index; } @@ -821,7 +828,7 @@ fmt_fix_float(bool colon, bool atsign) WRITEC_STREAM(overflowchar, fmt_stream); return; } - if (j < w && b[j-1] == '.') { + if (j < w && d < 0 && b[j-1] == '.') { b[j++] = '0'; b[j] = '\0'; } @@ -1007,10 +1014,6 @@ fmt_exponential_float(bool colon, bool atsign) w -= i + 2; if (j > w && overflowchar >= 0) goto OVER; - if (j < w && b[j-1] == '.') { - b[j++] = '0'; - b[j] = '\0'; - } if (j < w && b[0] == '.') { *--b = '0'; j++; @@ -1333,7 +1336,8 @@ fmt_asterisk(bool colon, bool atsign) fmt_not_colon_atsign(colon, atsign); if (atsign) { fmt_set_param(0, &n, INT, 0); - if (n < 0 || n >= fmt_end) + n += fmt_base; + if (n < fmt_base || n >= fmt_end) fmt_error("can't goto"); fmt_index = n; } else if (colon) { @@ -1374,10 +1378,10 @@ fmt_indirection(bool colon, bool atsign) } else { l = fmt_advance(); fmt_save; - fmt_base = alloca(length(l) * sizeof(cl_object)); - fmt_index = 0; - for (fmt_end = 0; !endp(l); fmt_end++, l = CDR(l)) - fmt_base[fmt_end] = CAR(l); + fmt_base = cl_stack_index(); + fmt_push_list(l); + fmt_index = fmt_base; + fmt_end = cl_stack_index(); fmt_jmp_buf = (int *)fmt_jmp_buf0; fmt_string = s; if ((up_colon = ecls_setjmp(fmt_jmp_buf))) { @@ -1385,6 +1389,7 @@ fmt_indirection(bool colon, bool atsign) fmt_error("illegal ~:^"); } else format(fmt_stream, 0, s->string.fillp); + cl_stack_set_index(fmt_base); fmt_restore; } } @@ -1572,10 +1577,10 @@ fmt_iteration(bool colon, bool atsign) if (!colon && !atsign) { l = fmt_advance(); fmt_save; - fmt_base = (cl_object *)alloca(length(l) * sizeof(cl_object)); - fmt_index = 0; - for (fmt_end = 0; !endp(l); fmt_end++, l = CDR(l)) - fmt_base[fmt_end] = CAR(l); + fmt_base = cl_stack_index(); + fmt_push_list(l); + fmt_index = fmt_base; + fmt_end = cl_stack_index(); fmt_jmp_buf = (int *)fmt_jmp_buf0; if (colon_close) goto L1; @@ -1590,6 +1595,7 @@ fmt_iteration(bool colon, bool atsign) } format(fmt_stream, o + i, j - i); } + cl_stack_set_index(fmt_base); fmt_restore; } else if (colon && !atsign) { int fl = 0; @@ -1598,7 +1604,7 @@ fmt_iteration(bool colon, bool atsign) fmt_save; for (l = l0; !endp(l); l = CDR(l)) fl += length(CAR(l)); - fmt_base = (cl_object *)alloca(fl * sizeof(cl_object)); + fmt_base = cl_stack_index(); fmt_jmp_buf = (int *)fmt_jmp_buf0; if (colon_close) goto L2; @@ -1608,9 +1614,9 @@ fmt_iteration(bool colon, bool atsign) break; l = CAR(l0); l0 = CDR(l0); - fmt_index = 0; - for (fmt_end = 0; !endp(l); fmt_end++, l = CDR(l)) - fmt_base[fmt_end] = CAR(l); + fmt_push_list(l); + fmt_index = fmt_base; + fmt_end = cl_stack_index(); if ((up_colon = ecls_setjmp(fmt_jmp_buf))) { if (--up_colon) break; @@ -1618,6 +1624,7 @@ fmt_iteration(bool colon, bool atsign) continue; } format(fmt_stream, o + i, j - i); + cl_stack_set_index(fmt_base); } fmt_restore; } else if (!colon && atsign) { @@ -1646,10 +1653,10 @@ fmt_iteration(bool colon, bool atsign) break; l = fmt_advance(); fmt_save; - fmt_base = (cl_object *)alloca(length(l) * sizeof(cl_object)); - fmt_index = 0; - for (fmt_end = 0; !endp(l); fmt_end++, l = CDR(l)) - fmt_base[fmt_end] = CAR(l); + fmt_base = cl_stack_index(); + fmt_push_list(l); + fmt_index = fmt_base; + fmt_end = cl_stack_index(); fmt_jmp_buf = (int *)fmt_jmp_buf0; if ((up_colon = ecls_setjmp(fmt_jmp_buf))) { fmt_restore; @@ -1659,6 +1666,7 @@ fmt_iteration(bool colon, bool atsign) continue; } format(fmt_stream, o + i, j - i); + cl_stack_set_index(fmt_base); fmt_restore; } } @@ -1668,12 +1676,13 @@ static void fmt_justification(volatile bool colon, bool atsign) { int mincol, colinc, minpad, padchar; - cl_object fields[16]; + volatile cl_index fields_start; + cl_index fields_end; fmt_old; jmp_buf fmt_jmp_buf0; - volatile int i, j, k, l, m, n, j0, l0; + volatile int i, j, k, l, m, j0, l0; int up_colon; - volatile int special = 0; + volatile cl_object special = Cnil; volatile int spare_spaces, line_length; fmt_max_param(4); @@ -1682,19 +1691,16 @@ fmt_justification(volatile bool colon, bool atsign) fmt_set_param(2, &minpad, INT, 0); fmt_set_param(3, &padchar, CHAR, ' '); - n = 0; + fields_start = cl_stack_index(); for (;;) { - if (n >= 16) - fmt_error("too many fields"); + cl_object this_field = make_string_output_stream(64); i = ctl_index; j0 = j = fmt_skip(); while (ctl_string[--j] != '~') ; - fields[n] = make_string_output_stream(64); fmt_save; fmt_jmp_buf = (int *)fmt_jmp_buf0; if ((up_colon = ecls_setjmp(fmt_jmp_buf))) { - --n; if (--up_colon) fmt_error("illegal ~:^"); fmt_restore1; @@ -1704,7 +1710,8 @@ fmt_justification(volatile bool colon, bool atsign) fmt_error("~> expected"); break; } - format(fields[n++], ctl_origin + i, j - i); + format(this_field, ctl_origin + i, j - i); + cl_stack_push(this_field->stream.object0); fmt_restore1; if (ctl_string[--j0] == '>') { if (ctl_string[--j0] != '~') @@ -1713,9 +1720,9 @@ fmt_justification(volatile bool colon, bool atsign) } else if (ctl_string[j0] != ';') fmt_error("~; expected"); else if (ctl_string[--j0] == ':') { - if (n != 1) + if (cl_stack_index() - fields_start != 1 || !Null(special)) fmt_error("illegal ~:;"); - special = 1; + special = cl_stack_pop(); for (j = j0; ctl_string[j] != '~'; --j) ; fmt_save; @@ -1726,9 +1733,19 @@ fmt_justification(volatile bool colon, bool atsign) } else if (ctl_string[j0] != '~') fmt_error("~; expected"); } - for (i = special, l = 0; i < n; i++) - l += fields[i]->stream.object0->string.fillp; - m = n - 1 - special; + /* + * Compute the length of items to be output. If the clause ~:; was + * found, the first item is not included. + */ + fields_end = cl_stack_index(); + for (i = fields_start, l = 0; i < fields_end; i++) + l += cl_stack[i]->string.fillp; + /* + * Count the number of segments that need padding, "M". If the colon + * modifier, the first item needs padding. If the @ modifier is + * present, the last modifier also needs padding. + */ + m = fields_end - fields_start - 1; if (m <= 0 && !colon && !atsign) { m = 0; colon = TRUE; @@ -1737,24 +1754,35 @@ fmt_justification(volatile bool colon, bool atsign) m++; if (atsign) m++; + /* + * Count the minimal length in which the text fits. This length must + * the smallest integer of the form l = mincol + k * colinc. If the + * length exceeds the line length, the text before the ~:; is output + * first. + */ l0 = l; l += minpad * m; for (k = 0; mincol + k * colinc < l; k++) ; l = mincol + k * colinc; - if (special != 0 && - FILE_COLUMN(fmt_stream) + l + spare_spaces >= line_length) - princ(fields[0]->stream.object0, fmt_stream); + if (special != Cnil && + FILE_COLUMN(fmt_stream) + l + spare_spaces > line_length) + princ(special, fmt_stream); + /* + * Output the text with the padding segments. The total number of + * padchars is kept in "l", and it is shared equally among all segments. + */ l -= l0; - for (i = special; i < n; i++) { - if (i > 0 || colon) + for (i = fields_start; i < fields_end; i++) { + if (i > fields_start || colon) for (j = l / m, l -= j, --m; j > 0; --j) WRITEC_STREAM(padchar, fmt_stream); - princ(fields[i]->stream.object0, fmt_stream); + princ(cl_stack[i], fmt_stream); } if (atsign) for (j = l; j > 0; --j) WRITEC_STREAM(padchar, fmt_stream); + cl_stack_set_index(fields_start); } static void @@ -1836,16 +1864,11 @@ RETRY: if (type_of(strm) == t_stream) { fmt_restore; unwind(nlj_fr, nlj_tag); } -#if 0 - fmt_base = (cl_object *)args; - fmt_index = 0; - fmt_end = narg - 2; -#else - fmt_base = (cl_object *)alloca((narg - 2) * sizeof(cl_object)); - fmt_index = 0; - for (fmt_end = 0; fmt_end < (narg - 2); fmt_end++) - fmt_base[fmt_end] = cl_nextarg(args); -#endif + fmt_base = cl_stack_index(); + for (narg -= 2; narg; narg--) + cl_stack_push(cl_nextarg(args)); + fmt_index = fmt_base; + fmt_end = cl_stack_index(); fmt_jmp_buf = (int *)fmt_jmp_buf0; if (symbol_value(@'si::*indent-formatted-output*') != Cnil) fmt_indents = FILE_COLUMN(strm); @@ -1859,6 +1882,7 @@ RETRY: if (type_of(strm) == t_stream) { format(strm, 0, string->string.fillp); FLUSH_STREAM(strm); } + cl_stack_set_index(fmt_base); frs_pop(); fmt_restore; @(return (x == OBJNULL? Cnil : x)) diff --git a/src/c/gbc.d b/src/c/gbc.d index 335377f7d..143f27c9e 100644 --- a/src/c/gbc.d +++ b/src/c/gbc.d @@ -438,11 +438,11 @@ mark_stack_conservative(cl_ptr bottom, cl_ptr top) static void mark_phase(void) { - register int i; - register struct package *pp; - register bds_ptr bdp; - register frame_ptr frp; - register ihs_ptr ihsp; + int i; + struct package *pp; + bds_ptr bdp; + frame_ptr frp; + cl_object *sp; mark_object(Cnil); mark_object(Ct); @@ -457,14 +457,15 @@ mark_phase(void) clwp = pdp->pd_lpd; #endif THREADS - mark_contblock(CIRCLEbase, CIRCLEsize*sizeof(cl_object)); - + mark_contblock(cl_stack, cl_stack_size * sizeof(*cl_stack)); + for (sp=cl_stack; sp < cl_stack_top; sp++) + mark_object(*sp); + for (i=0; ibds_sym); @@ -473,14 +474,8 @@ mark_phase(void) for (frp = frs_org; frp <= frs_top; frp++) { mark_object(frp->frs_val); - mark_object(frp->frs_lex); } - for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++) { - mark_object(ihsp->ihs_function); - mark_object(ihsp->ihs_base); - } - mark_object(lex_env); #ifdef THREADS diff --git a/src/c/init.d b/src/c/init.d index 0fe49e6cd..b973f6717 100644 --- a/src/c/init.d +++ b/src/c/init.d @@ -109,5 +109,6 @@ init_lisp(void) #ifdef RUNTIME SYM_VAL(@'*features*') = CONS(make_keyword("RUNTIME"), SYM_VAL(@'*features*')); #endif + ihs_push(_intern("TOP-LEVEL", system_package), Cnil); init_lisp_libs(); } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 58bc96d2c..b23cae7fe 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -18,32 +18,114 @@ #define next_code(v) *(v++) #undef frs_pop -#define frs_pop() { stack->vector.fillp = frs_top->frs_sp; frs_top--; } +#define frs_pop() { cl_stack_top = cl_stack + frs_top->frs_sp; frs_top--; } + +/* -------------------- INTERPRETER STACK -------------------- */ + +cl_index cl_stack_size = 0; +cl_object *cl_stack = NULL; +cl_object *cl_stack_top = NULL; +cl_object *cl_stack_limit = NULL; static void -lambda_bind_var(cl_object var, cl_object val, cl_object specials) +cl_stack_set_size(cl_index new_size) { - if (!member_eq(var, specials)) - CAR(lex_env) = CONS(CONS(var, CONS(val, Cnil)), CAR(lex_env)); - else { - CAR(lex_env) = CONS(CONS(var, Cnil), CAR(lex_env)); - bds_bind(var, val); - } + cl_index top = cl_stack_top - cl_stack; + cl_object *new_stack; + + printf("*+*+*+\n"); + + if (top > new_size) + FEerror("Internal error: cannot shrink stack that much.",0); + + start_critical_section(); + + new_stack = alloc(new_size * sizeof(cl_object)); + memcpy(new_stack, cl_stack, cl_stack_size * sizeof(cl_object)); + cl_stack_size = new_size; + cl_stack = new_stack; + cl_stack_top = cl_stack + top; + cl_stack_limit = cl_stack + (new_size - 2); + + end_critical_section(); } +void +cl_stack_grow(void) +{ + cl_stack_set_size(cl_stack_size + LISP_PAGESIZE); +} + +void +cl_stack_push(cl_object x) { + if (cl_stack_top >= cl_stack_limit) + cl_stack_grow(); + *(cl_stack_top++) = x; +} + +cl_object +cl_stack_pop() { + if (cl_stack_top == cl_stack) + FEerror("Internal error: stack underflow.",0); + return *(--cl_stack_top); +} + +cl_index +cl_stack_index() { + return cl_stack_top - cl_stack; +} + +void +cl_stack_set_index(cl_index index) { + cl_object *new_top = cl_stack + index; + if (new_top > cl_stack_top) + FEerror("Internal error: tried to advance stack.",0); + cl_stack_top = new_top; +} + +void +cl_stack_insert(cl_index where, cl_index n) { + if (cl_stack_top + n > cl_stack_limit) { + cl_index delta = (n + (LISP_PAGESIZE-1))/LISP_PAGESIZE; + cl_stack_set_size(cl_stack_size + delta * LISP_PAGESIZE); + } + cl_stack_top += n; + memmove(&cl_stack[where+n], &cl_stack[where], + (cl_stack_top - cl_stack) * sizeof(*cl_stack)); +} + + +void +cl_stack_pop_n(cl_index index) { + cl_object *new_top = cl_stack_top - index; + if (new_top < cl_stack) + FEerror("Internal error: stack underflow.",0); + cl_stack_top = new_top; +} + +/* -------------------- LAMBDA FUNCTIONS -------------------- */ + static void bind_var(register cl_object var, register cl_object val) { - CAR(lex_env) = CONS(CONS(var, CONS(val, Cnil)), CAR(lex_env)); + CAR(lex_env) = CONS(var, CONS(val, CAR(lex_env))); } static void bind_special(register cl_object var, register cl_object val) { - CAR(lex_env) = CONS(CONS(var, Cnil), CAR(lex_env)); bds_bind(var, val); } +static void +lambda_bind_var(cl_object var, cl_object val, cl_object specials) +{ + if (!member_eq(var, specials)) + bind_var(var, val); + else + bind_special(var, val); +} + static cl_object * lambda_bind(int narg, cl_object lambda_list, cl_object *args) { @@ -148,7 +230,7 @@ lambda_bind(int narg, cl_object lambda_list, cl_object *args) cl_object lambda_apply(int narg, cl_object fun, cl_object *args) -{ cl_object lex_old = lex_env; +{ cl_object output, name, *body; bds_ptr old_bds_top; volatile bool block, closure; @@ -156,8 +238,8 @@ lambda_apply(int narg, cl_object fun, cl_object *args) if (type_of(fun) != t_bytecodes) FEinvalid_function(fun); - /* Set the lexical environment of the function */ - ihs_check; + /* 1) Save the lexical environment and set up a new one */ + cl_stack_push(lex_env); if (Null(fun->bytecodes.lex)) lex_env = CONS(Cnil, Cnil); else @@ -190,67 +272,12 @@ lambda_apply(int narg, cl_object fun, cl_object *args) END: if (block) frs_pop(); bds_unwind(old_bds_top); - lex_env = lex_old; ihs_pop(); + lex_env = cl_stack_pop(); returnn(VALUES(0)); } -/* ----------------- BYTECODE STACK --------------- */ - -cl_object stack = OBJNULL; - -static void -stack_grow(void) { - cl_object *old_data = stack->vector.self.t; - cl_index old_size = stack->vector.fillp; - stack->vector.dim += 128; - array_allocself(stack); - memcpy(stack->vector.self.t, old_data, old_size*sizeof(cl_object)); -} - -static void -push1(register cl_object op) { - cl_index where; - where = stack->vector.fillp; - if (where >= stack->vector.dim) - stack_grow(); - stack->vector.self.t[where] = op; - stack->vector.fillp++; -} - -static cl_object -pop1() { - return stack->vector.self.t[--stack->vector.fillp]; -} - -static cl_index -get_sp_index() { - return stack->vector.fillp; -} - -static void -dec_sp_index(register cl_index delta) { - stack->vector.fillp -= delta; -} - -static void -set_sp_index(register cl_index sp) { - if (stack->vector.fillp < sp) - FEerror("Tried to advance stack", 0); - stack->vector.fillp = sp; -} - -static cl_object * -get_sp() { - return stack->vector.self.t + stack->vector.fillp; -} - -static cl_object * -get_sp_at(cl_index where) { - return stack->vector.self.t + where; -} - #ifdef NO_ARGS_ARRAY cl_object va_lambda_apply(int narg, cl_object fun, va_list args) @@ -258,9 +285,9 @@ va_lambda_apply(int narg, cl_object fun, va_list args) cl_object out; int i; for (i=narg; i; i--) - push1(cl_nextarg(args)); - out = lambda_apply(narg, fun, get_sp()-narg); - dec_sp_index(narg); + cl_stack_push(cl_nextarg(args)); + out = lambda_apply(narg, fun, cl_stack_top-narg); + cl_stack_pop_n(narg); return out; } @@ -271,9 +298,9 @@ va_gcall(int narg, cl_object fun, va_list args) cl_object out; int i; for (i=narg; i; i--) - push1(cl_nextarg(args)); - out = gcall(narg, fun, get_sp()-narg); - dec_sp_index(narg); + cl_stack_push(cl_nextarg(args)); + out = gcall(narg, fun, cl_stack_top-narg); + cl_stack_pop_n(narg); return out; } #endif @@ -308,78 +335,102 @@ search_symbol_function(register cl_object fun) { } static cl_object -search_symbol_value(register cl_object s) { +search_local(register cl_object s) { cl_object x; - /* x = lex_var_sch(form); */ - for (x = CAR(lex_env); CONSP(x); x = CDR(x)) - if (CAAR(x) == s) { - x = CDAR(x); - if (ENDP(x)) break; - return CAR(x); + + for (x = CAR(lex_env); CONSP(x); x = CDDR(x)) + if (CAR(x) == s) { + return CADR(x); } - x = SYM_VAL(s); + FEerror("Internal error: local ~S not found.", 1, s); +} + +static cl_object +setq_local(register cl_object s, register cl_object v) { + cl_object x; + for (x = CAR(lex_env); CONSP(x); x = CDDR(x)) + if (CAR(x) == s) { + CADR(x) = v; + return; + } + FEerror("Internal error: local ~S not found.", 1, s); +} + +static cl_object +search_global(register cl_object s) { + cl_object x = SYM_VAL(s); if (x == OBJNULL) FEunbound_variable(s); return x; } static cl_object -interpret_call(int narg, cl_object fun, cl_object *args) { +interpret_call(int narg, cl_object fun) { + cl_object *args; cl_object x; + args = cl_stack_top - narg; AGAIN: switch (type_of(fun)) { case t_cfun: - ihs_push_funcall(fun->cfun.name); + ihs_push(fun->cfun.name, Cnil); x = APPLY(narg, fun->cfun.entry, args); ihs_pop(); - return x; + break; case t_cclosure: /* FIXME! Shouldn't we register this call somehow? */ - return APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, args); + x = APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, args); + break; #ifdef CLOS case t_gfun: - ihs_push_funcall(fun->gfun.name); + ihs_push(fun->gfun.name, Cnil); x = gcall(narg, fun, args); ihs_pop(); - return x; + break; #endif case t_bytecodes: - return lambda_apply(narg, fun, args); + x = lambda_apply(narg, fun, args); + break; case t_symbol: fun = search_symbol_function(fun); goto AGAIN; default: + FEinvalid_function(fun); } - FEinvalid_function(fun); + cl_stack_pop_n(narg); + return x; } /* Similar to interpret_call(), but looks for symbol functions in the global environment. */ static cl_object -interpret_funcall(int narg, cl_object fun, cl_object *args) { +interpret_funcall(int narg, cl_object fun) { + cl_object *args; cl_object x; + args = cl_stack_top - narg; AGAIN: switch (type_of(fun)) { case t_cfun: - ihs_push_funcall(fun->cfun.name); + ihs_push(fun->cfun.name, Cnil); x = APPLY(narg, fun->cfun.entry, args); ihs_pop(); - return x; + break; case t_cclosure: /* FIXME! Shouldn't we register this call somehow? */ - return APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, args); + x = APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, args); + break; #ifdef CLOS case t_gfun: - ihs_push_funcall(fun->gfun.name); + ihs_push(fun->gfun.name, Cnil); x = gcall(narg, fun, args); ihs_pop(); - return x; + break; #endif case t_bytecodes: - return lambda_apply(narg, fun, args); + x = lambda_apply(narg, fun, args); + break; case t_symbol: { cl_object function = SYM_FUN(fun); if (function == OBJNULL) @@ -388,8 +439,10 @@ interpret_funcall(int narg, cl_object fun, cl_object *args) { goto AGAIN; } default: + FEinvalid_function(fun); } - FEinvalid_function(fun); + cl_stack_pop_n(narg); + return x; } /* -------------------- THE INTERPRETER -------------------- */ @@ -398,15 +451,19 @@ static cl_object * interpret_block(cl_object *vector) { cl_object * volatile exit, name; cl_object id = new_frame_id(); - cl_object lex_old = lex_env; - lex_copy(); + /* 1) Save current environment */ + cl_stack_push(CDR(lex_env)); + + /* 2) Set up a block with given name */ exit = packed_label(vector - 1); lex_block_bind(next_code(vector), id); if (frs_push(FRS_CATCH,id) == 0) vector = interpret(vector); frs_pop(); - lex_env = lex_old; + + /* 3) Restore environment */ + CDR(lex_env) = cl_stack_pop(); return exit; } @@ -423,15 +480,18 @@ interpret_catch(cl_object *vector) { static cl_object * interpret_tagbody(cl_object *vector) { cl_index i, ntags = get_oparg(vector[-1]); - cl_object lex_old = lex_env; cl_object id = new_frame_id(); cl_object *aux, *tag_list = vector; - lex_copy(); + /* 1) Save current environment */ + cl_stack_push(CDR(lex_env)); + + /* 2) Bind tags */ aux = vector; for (i=0; ibytecodes.data[0], f); } vector = interpret(vector); - lex_env = lex_old; + + /* 4) Restore environment */ + CDR(lex_env) = cl_stack_pop(); return vector; } static cl_object * interpret_labels(cl_object *vector) { - cl_object lex_old = lex_env; cl_index i, nfun = get_oparg(vector[-1]); - cl_object l; + cl_object l, lex; - lex_copy(); + /* 1) Save current environment */ + cl_stack_push(CDR(lex_env)); + + /* 2) Build up a new environment with all functions */ for (i=0; ibytecodes.data[0], f); } - /* Update the closures so that all functions can call each other */ + lex = CONS(CAR(lex_env), CDR(lex_env)); + + /* 3) Update the closures so that all functions can call each other */ for (i=0, l=CDR(lex_env); isymbol.stype == stp_constant) @@ -668,11 +764,13 @@ interpret_msetq(cl_object *vector) static cl_object * interpret_progv(cl_object *vector) { cl_object values = VALUES(0); - cl_object vars = pop1(); - cl_object lex_old = lex_env; - bds_ptr old_bds_top = bds_top; + cl_object vars = cl_stack_pop(); - lex_copy(); + /* 1) Save current environment */ + bds_ptr old_bds_top = bds_top; + cl_stack_push(CAR(lex_env)); + + /* 2) Add new bindings */ while (!endp(vars)) { if (values == Cnil) bds_bind(CAR(vars), OBJNULL); @@ -683,19 +781,24 @@ interpret_progv(cl_object *vector) { vars = CDR(vars); } vector = interpret(vector); - lex_env = lex_old; + + /* 3) Restore environment */ + CAR(lex_env) = cl_stack_pop(); bds_unwind(old_bds_top); return vector; } static cl_object * interpret_pushenv(cl_object *vector) { - cl_object lex_old = lex_env; + /* 1) Save environment */ bds_ptr old_bds_top = bds_top; + cl_stack_push(CAR(lex_env)); - lex_copy(); + /* 2) Execute */ vector = interpret(vector); - lex_env = lex_old; + + /* 3) Restore environment */ + CAR(lex_env) = cl_stack_pop(); bds_unwind(old_bds_top); return vector; } @@ -709,11 +812,6 @@ interpret(cl_object *vector) { BEGIN: s = next_code(vector); t = type_of(s); - if (t == t_symbol) { - VALUES(0) = search_symbol_value(s); - NValues = 1; - goto BEGIN; - } if (t != t_fixnum) { VALUES(0) = s; NValues = 1; @@ -721,13 +819,24 @@ interpret(cl_object *vector) { } switch (GET_OP(s)) { case OP_PUSHQ: - push1(next_code(vector)); + cl_stack_push(next_code(vector)); break; case OP_PUSH: - push1(VALUES(0)); + cl_stack_push(VALUES(0)); break; case OP_PUSHV: - push1(search_symbol_value(next_code(vector))); + cl_stack_push(search_local(next_code(vector))); + break; + case OP_PUSHVS: + cl_stack_push(search_global(next_code(vector))); + break; + case OP_VAR: + VALUES(0) = search_local(next_code(vector)); + NValues = 1; + break; + case OP_VARS: + VALUES(0) = search_global(next_code(vector)); + NValues = 1; break; case OP_QUOTE: VALUES(0) = next_code(vector); @@ -743,7 +852,7 @@ interpret(cl_object *vector) { case OP_PUSHVALUES: { int i; for (i=0; isymbol.stype == stp_constant) FEassignment_to_constant(var); else - SYM_VAL(var) = pop1(); + SYM_VAL(var) = cl_stack_pop(); Values[0] = Cnil; NValues = 1; break; @@ -897,11 +1002,11 @@ interpret(cl_object *vector) { cl_fixnum n = get_oparg(s); NValues = n; while (n) - VALUES(--n) = pop1(); + VALUES(--n) = cl_stack_pop(); break; } case OP_NTHVAL: { - cl_index n = fix(pop1()); + cl_index n = fix(cl_stack_pop()); if (n < 0 || n >= NValues) VALUES(0) = Cnil; else @@ -933,15 +1038,13 @@ interpret(cl_object *vector) { @(defun si::interpreter_stack () @ - @(return stack) + @(return Cnil) @) void init_interpreter(void) { - register_root(&stack); - stack = alloc_simple_vector(128, aet_object); - array_allocself(stack); - stack->vector.hasfillp = TRUE; - stack->vector.fillp = 0; + cl_stack = NULL; + cl_stack_size = 0; + cl_stack_set_size(8*LISP_PAGESIZE); } diff --git a/src/c/lex.d b/src/c/lex.d index f4b9991ed..2c17c1289 100644 --- a/src/c/lex.d +++ b/src/c/lex.d @@ -36,18 +36,6 @@ lex_fun_bind(cl_object name, cl_object fun) CDR(lex_env) = CONS(list(3, name, @'function', fun), CDR(lex_env)); } -void -lex_symbol_macro_bind(cl_object name, cl_object exp_fun) -{ - CAR(lex_env) = CONS(list(3, name, @'si::symbol-macro', exp_fun), CAR(lex_env)); -} - -void -lex_macro_bind(cl_object name, cl_object exp_fun) -{ - CDR(lex_env) = CONS(list(3, name, @'macro', exp_fun), CDR(lex_env)); -} - void lex_tag_bind(cl_object tag, cl_object id) { diff --git a/src/c/lwp.d b/src/c/lwp.d index 124d1b270..ae51f2b43 100644 --- a/src/c/lwp.d +++ b/src/c/lwp.d @@ -114,10 +114,7 @@ make_pd() npd->lwp_cs_limit = npd->lwp_cs_org + STACK_SIZE; #endif /* invocation history stack */ - npd->lwp_ihssize = IHSSIZE + 2*IHSGETA; - npd->lwp_ihsorg = malloc(npd->lwp_ihssize * sizeof(*npd->lwp_ihsorg)); - npd->lwp_ihstop = npd->lwp_ihsorg-1; - npd->lwp_ihslimit = &npd->lwp_ihsorg[npd->lwp_ihssize - 2*IHSGETA]; + npd->lwp_ihstop = 0 /* frame stack */ npd->lwp_frs_size = FRSSIZE + 2*FRSGETA; npd->lwp_frs_org = malloc(npd->lwp_frs_size * sizeof(*npd->lwp_frs_org)); diff --git a/src/c/main.d b/src/c/main.d index a83c40aaf..ac8b5e364 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -102,7 +102,6 @@ main(int argc, char **argv) NULL); /* geometry */ } #endif - ihs_push(_intern("TOP-LEVEL", system_package), Cnil); funcall(1, @'si::top-level'); return(0); } diff --git a/src/c/print.d b/src/c/print.d index 2875f7a68..6b445d980 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -111,10 +111,7 @@ cl_object @'si::sharp-exclamation'; #define isp clwp->lwp_isp #define iisp clwp->lwp_iisp -#define CIRCLEsize clwp->lwp_CIRCLEsize #define CIRCLEbase clwp->lwp_CIRCLEbase -#define CIRCLEtop clwp->lwp_CIRCLEtop -#define CIRCLElimit clwp->lwp_CIRCLElimit #else static short queue[Q_SIZE]; @@ -126,10 +123,7 @@ static int qc; static int isp; static int iisp; -cl_index CIRCLEsize; -cl_object *CIRCLEbase; -cl_object *CIRCLEtop; -cl_object *CIRCLElimit; +cl_fixnum CIRCLEbase; cl_object PRINTstream; #endif THREADS @@ -139,7 +133,7 @@ cl_object PRINTstream; static void flush_queue (bool force); static void write_decimal1 (int i); static void travel_push_object (cl_object x); -static cl_object *searchPRINTcircle(cl_object x); +static cl_index searchPRINTcircle(cl_object x); static bool doPRINTcircle(cl_object x); @@ -550,6 +544,7 @@ call_structure_print_function(cl_object x, int level) bool a = PRINTarray; cl_object ps = PRINTstream; cl_object pc = PRINTcase; + cl_fixnum cb = CIRCLEbase; short ois[IS_SIZE]; @@ -612,6 +607,7 @@ call_structure_print_function(cl_object x, int level) qt = oqt; qh = oqh; + CIRCLEbase = cb; PRINTcase = pc; PRINTstream = ps; PRINTarray = a; @@ -650,6 +646,7 @@ call_print_object(cl_object x, int level) bool a = PRINTarray; cl_object ps = PRINTstream; cl_object pc = PRINTcase; + cl_index cb = CIRCLEbase; short ois[IS_SIZE]; @@ -711,6 +708,7 @@ call_print_object(cl_object x, int level) qt = oqt; qh = oqh; + CIRCLEbase = cb; PRINTcase = pc; PRINTstream = ps; PRINTarray = a; @@ -1174,11 +1172,11 @@ write_object(cl_object x, int level) break; } if (PRINTcircle) { - cl_object *vp = searchPRINTcircle(x); - if (vp != NULL) { - if (vp[1] != Cnil) { + cl_index vp = searchPRINTcircle(x); + if (vp != 0) { + if (cl_stack[vp] != Cnil) { write_str(" . #"); - write_decimal((vp-CIRCLEbase)/2); + write_decimal((vp-CIRCLEbase)/2+1); write_ch('#'); goto RIGHT_PAREN; } else { @@ -1460,58 +1458,62 @@ write_object(cl_object x, int level) } /* To print circular structures, we traverse the structure by adding - a pair to the array CIRCLEbase for each element visited. + a pair to the interpreter stack for each element visited. flag is initially NIL and becomes T if the element is visited again. After the visit we squeeze out all the non circular elements. The flags is used during printing to distinguish between the first visit to the element. */ -/* Allocates space for travel_push: if not enough, get back with - longjmp and increase it */ - static void setupPRINTcircle(cl_object x) { - cl_object *vp, *vq; + cl_object *vp, *vq, *CIRCLEtop; - CIRCLEsize = 4000; - CIRCLEbase = alloc_atomic(CIRCLEsize * sizeof(cl_object)); - CIRCLEtop = CIRCLEbase; - CIRCLElimit = &CIRCLEbase[CIRCLEsize]; + if (CIRCLEbase >= 0) + FEerror("Internal error: tried to overwrite CIRCLEbase.",0); + if (!PRINTcircle) { + CIRCLEbase = -1; + return; + } + CIRCLEbase = cl_stack_index(); travel_push_object(x); + CIRCLEtop = cl_stack_top; /* compact shared elements towards CIRCLEbase */ - for (vp = vq = CIRCLEbase; vp < CIRCLEtop; vp += 2) + for (vp = vq = &cl_stack[CIRCLEbase]; vp < CIRCLEtop; vp += 2) if (vp[1] != Cnil) { vq[0] = vp[0]; vq[1] = Cnil; vq += 2; } - CIRCLEtop = vq; + cl_stack_set_index(vq - cl_stack); } -static cl_object * +static cl_index searchPRINTcircle(cl_object x) { - cl_object *vp; + cl_object *vp, *CIRCLEtop; - for (vp = CIRCLEbase; vp < CIRCLEtop; vp += 2) + if (CIRCLEbase < 0) + return 0; + CIRCLEtop = cl_stack_top; + for (vp = &cl_stack[CIRCLEbase]; vp < CIRCLEtop; vp += 2) if (vp[0] == x) - return vp; - return NULL; + return vp-cl_stack+1; + return 0; } static bool doPRINTcircle(cl_object x) { - cl_object *vp = searchPRINTcircle(x); - if (vp != NULL) { + cl_index vp = searchPRINTcircle(x); + if (vp != 0) { write_ch('#'); - write_decimal((vp-CIRCLEbase)/2); - if (vp[1] != Cnil) { + write_decimal((vp-CIRCLEbase)/2+1); + if (cl_stack[vp] != Cnil) { write_ch('#'); return TRUE; /* All is done */ } else { write_ch('='); - vp[1] = Ct; + cl_stack[vp] = Ct; } } return FALSE; /* Print the structure */ @@ -1522,7 +1524,7 @@ travel_push_object(cl_object x) { enum type t; cl_index i; - cl_object *vp; + cl_object *vp, *CIRCLEtop; cs_check(x); @@ -1537,25 +1539,14 @@ BEGIN: #endif CLOS !(t == t_symbol && Null(x->symbol.hpack))) return; - for (vp = CIRCLEbase; vp < CIRCLEtop; vp += 2) - if (x == *vp) { - /* if (vp[1] == Cnil) */ vp[1] = Ct; + CIRCLEtop = cl_stack_top; + for (vp = &cl_stack[CIRCLEbase]; vp < CIRCLEtop; vp += 2) + if (x == vp[0]) { + vp[1] = Ct; return; } - if (CIRCLEtop >= CIRCLElimit) { - /* allocate more space */ - cl_object *ptr; - int newsize = CIRCLEsize + 4000; - ptr = alloc_atomic(newsize * sizeof(cl_object)); - memcpy(ptr, CIRCLEbase, CIRCLEsize * sizeof(cl_object)); - CIRCLEsize = newsize; - CIRCLEtop = (CIRCLEtop - CIRCLEbase) + ptr; - CIRCLEbase = ptr; - CIRCLElimit = &CIRCLEbase[CIRCLEsize]; - } - CIRCLEtop[0] = x; - CIRCLEtop[1] = Cnil; - CIRCLEtop += 2; + cl_stack_push(x); + cl_stack_push(Cnil); switch (t) { case t_array: @@ -1646,6 +1637,7 @@ RETRY: if (type_of(PRINTstream) == t_stream) { PRINTlength = fix(y); PRINTarray = symbol_value(@'*print-array*') != Cnil; /* setupPRINTcircle(x); */ + CIRCLEbase = -1; if (PRINTpretty) { qh = qt = qc = 0; isp = iisp = 0; @@ -1660,6 +1652,10 @@ RETRY: if (type_of(PRINTstream) == t_stream) { void cleanupPRINT(void) { + if (CIRCLEbase >= 0) { + cl_stack_set_index(CIRCLEbase); + CIRCLEbase = -1; + } if (PRINTpretty) flush_queue(TRUE); } diff --git a/src/c/read.d b/src/c/read.d index 2a6c77539..e142f6cc3 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -924,30 +924,19 @@ static *---------------------------------------------------------------------- */ -#define INCREMENT 64 -#define ESTACK(st) volatile int _esize = 0; cl_object *(st), *(st ## 0); -#define ETOP(st) (st ## 0) - -#define EPUSH(st, val, count) \ - { int i; if (count == _esize) { \ - st = (cl_object *)alloca(INCREMENT*sizeof(cl_object)); \ - for ( i = 0; i < _esize; i++) \ - st[i] = st ## 0[i]; \ - (st ## 0) = st; st += _esize;\ - _esize += INCREMENT; \ - }; *(st)++ = (val);} - - static @(defun si::sharp_left_parenthesis_reader (in c d) - int dim, dimcount, i, a; + bool fixed_size; + cl_index dim, dimcount, i, a; + cl_index sp = cl_stack_index(); cl_object x, last; - ESTACK(vsp); @ if (Null(d) || READsuppress) - dim = -1; - else if (FIXNUMP(d)) - dim = fix(d); + fixed_size = FALSE; + else { + fixed_size = TRUE; + dim = fixnnint(d); + } if (backq_level > 0) { unreadc_stream('(', in); x = read_object(in); @@ -956,7 +945,7 @@ static FEerror(",at or ,. has appeared in an illegal position.", 0); if (a == QUOTE) { for (dimcount = 0; !endp(x); x = CDR(x), dimcount++) - EPUSH(vsp, CAR(x), dimcount); + cl_stack_push(CAR(x)); goto L; } @(return list(4, siScomma, @'apply', @@ -967,38 +956,42 @@ static x = read_object(in); if (x == OBJNULL) break; - EPUSH(vsp, x, dimcount); + cl_stack_push(x); } L: - if (dim >= 0) { + if (fixed_size) { if (dimcount > dim) FEerror("Too many elements in #(...).", 0); if (dimcount == 0) FEerror("Cannot fill the vector #().", 0); - else last = vsp[-1]; + else last = cl_stack_top[-1]; } else - dim = dimcount; + dim = dimcount; x = alloc_simple_vector(dim, aet_object); x->vector.self.t = alloc_align(dim * sizeof(cl_object), sizeof(cl_object)); for (i = 0; i < dim; i++) - x->vector.self.t[i] = (i < dimcount) ? ETOP(vsp)[i] : last; + x->vector.self.t[i] = (i < dimcount) ? cl_stack[sp+i] : last; + cl_stack_pop_n(dimcount); @(return x) @) static @(defun si::sharp_asterisk_reader (in c d) - int dim, dimcount, i; + bool fixed_size; + cl_index dim, dimcount, i; + cl_index sp = cl_stack_index(); cl_object x, last, elt; - ESTACK(vsp); @ if (READsuppress) { read_constituent(in); @(return Cnil) } if (Null(d)) - dim = -1; - else if (FIXNUMP(d)) - dim = fix(d); + fixed_size = FALSE; + else { + dim = fixnnint(d); + fixed_size = TRUE; + } for (dimcount = 0 ;; dimcount++) { if (stream_at_end(in)) break; @@ -1007,27 +1000,27 @@ static unread_char(x, in); break; } - EPUSH(vsp, x, dimcount); + cl_stack_push(x); } - if (dim >= 0) { + if (fixed_size) { if (dimcount > dim) FEerror("Too many elements in #*....", 0); if (dimcount == 0) FEerror("Cannot fill the bit-vector #*.", 0); - else last = vsp[-1]; + else last = cl_stack_top[-1]; } else { - dim = dimcount; /* Beppe ? */ - last = MAKE_FIXNUM(0); + dim = dimcount; } x = alloc_simple_bitvector(dim); x->vector.self.bit = alloc_atomic((dim + CHAR_BIT - 1)/CHAR_BIT); for (i = 0; i < dim; i++) { - elt = (i < dimcount) ? ETOP(vsp)[i] : last; + elt = (i < dimcount) ? cl_stack[sp+i] : last; if (char_code(elt) == '0') x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT); else x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; - } + } + cl_stack_pop_n(dimcount); @(return x) @) diff --git a/src/c/stacks.d b/src/c/stacks.d index 9c2456675..ba1d3adf7 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -26,10 +26,7 @@ bds_ptr bds_org; bds_ptr bds_limit; bds_ptr bds_top; -size_t ihs_size; -ihs_ptr ihs_org; -ihs_ptr ihs_limit; -ihs_ptr ihs_top; +cl_index ihs_top; size_t frs_size; frame_ptr frs_org; @@ -98,17 +95,7 @@ get_bds_ptr(cl_object x) /******************** INVOCATION STACK **********************/ -void -ihs_overflow(void) -{ - --ihs_top; - if (ihs_limit > ihs_org + ihs_size) - error("invocation history stack overflow."); - ihs_limit += IHSGETA; - FEerror("Invocation history stack overflow.", 0); -} - -cl_object +static cl_object ihs_function_name(cl_object x) { cl_object y; @@ -132,52 +119,102 @@ ihs_function_name(cl_object x) } } +void +ihs_push(cl_object function, cl_object env) +{ + cl_stack_push(function); + cl_stack_push(env); + cl_stack_push(MAKE_FIXNUM(ihs_top)); + ihs_top = cl_stack_index(); +} + +void +ihs_pop() +{ + cl_stack_set_index(ihs_top); + ihs_top = fix(cl_stack_top[-1]); + cl_stack_pop_n(3); +} + +static cl_object * +get_ihs_ptr(cl_index n) +{ + cl_object *sp = &cl_stack[n]; + + if (sp > cl_stack && sp <= cl_stack_top) + return sp; + FEerror("~S is an illegal ihs index.", 1, MAKE_FIXNUM(n)); +} + +static cl_index +ihs_prev(cl_index n) +{ + cl_object *sp = get_ihs_ptr(n); + n = fixnnint(sp[-1]); + return n; +} + cl_object ihs_top_function_name(void) { - cl_object x; - ihs_ptr h = ihs_top; + cl_index h = ihs_top; - while (h >= ihs_org) { - x = ihs_function_name(h->ihs_function); - if (x != Cnil) - return(x); - h--; + while (h > 0) { + cl_object *sp = get_ihs_ptr(h); + cl_object next_h = sp[-1]; + cl_object lex_env = sp[-2]; + cl_object name = ihs_function_name(sp[-3]); + if (name != Cnil) + return name; + h = fixnnint(next_h); } return(Cnil); } -/* - Lisp interface to IHS -*/ - -static ihs_ptr -get_ihs_ptr(cl_object x) -{ - ihs_ptr p; - - if (FIXNUMP(x)) { - p = ihs_org + fix(x); - if (ihs_org <= p && p <= ihs_top) - return(p); - } - FEerror("~S is an illegal ihs index.", 1, x); -} - -@(defun si::ihs_top () +@(defun si::ihs_top (name) + cl_index h = ihs_top; + cl_object *sp; @ - @(return MAKE_FIXNUM(ihs_top - ihs_org)) + name = ihs_function_name(name); + while (h > 0) { + cl_object *sp = get_ihs_ptr(h); + cl_object fun = sp[-3]; + if (ihs_function_name(fun) == name) + break; + h = fixnnint(sp[-1]); + } + if (h == 0) + h = ihs_top; + @(return MAKE_FIXNUM(h)) +@) + +@(defun si::ihs-prev (x) +@ + @(return MAKE_FIXNUM(ihs_prev(fixnnint(x)))) +@) + +@(defun si::ihs-next (x) + cl_index h1 = ihs_top, h2 = ihs_top; + cl_index n = fixnnint(x); +@ + while (h2 > n) { + h1 = h2; + h2 = ihs_prev(h1); + } + if (h2 == n) + @(return MAKE_FIXNUM(h1)) + FEerror("Internal error: ihs record ~S not found.", 1, x); @) @(defun si::ihs_fun (arg) @ - @(return get_ihs_ptr(arg)->ihs_function) + @(return get_ihs_ptr(fixnnint(arg))[-3]) @) @(defun si::ihs_env (arg) cl_object lex; @ - lex = get_ihs_ptr(arg)->ihs_base; + lex = get_ihs_ptr(fixnnint(arg))[-2]; @(return CONS(car(lex),cdr(lex))) @) @@ -210,7 +247,7 @@ _frs_push(register enum fr_class class, register cl_object val) frs_top->frs_class = class; frs_top->frs_val = val; frs_top->frs_ihs = ihs_top; - frs_top->frs_sp = stack->vector.fillp; + frs_top->frs_sp = cl_stack_index(); return frs_top; } @@ -225,7 +262,7 @@ unwind(frame_ptr fr, cl_object tag) lex_env = frs_top->frs_lex; ihs_top = frs_top->frs_ihs; bds_unwind(frs_top->frs_bds_top); - stack->vector.fillp = frs_top->frs_sp; + cl_stack_set_index(frs_top->frs_sp); ecls_longjmp(frs_top->frs_jmpbuf, 1); /* never reached */ } @@ -295,14 +332,14 @@ get_frame_ptr(cl_object x) @(defun si::frs_ihs (arg) @ - @(return MAKE_FIXNUM(get_frame_ptr(arg)->frs_ihs - ihs_org)) + @(return MAKE_FIXNUM(get_frame_ptr(arg)->frs_ihs)) @) @(defun si::sch_frs_base (fr ihs) frame_ptr x; - ihs_ptr y; + cl_index y; @ - y = get_ihs_ptr(ihs); + y = fixnnint(ihs); for (x = get_frame_ptr(fr); x <= frs_top && x->frs_ihs < y; x++); @(return ((x > frs_top) ? Cnil : MAKE_FIXNUM(x - frs_org))) @) @@ -319,10 +356,6 @@ get_frame_ptr(cl_object x) frs_limit = frs_org + (frs_size - 2*FRSGETA); else error("can't reset frs_limit."); - if (ihs_top < ihs_org + (ihs_size - 2*IHSGETA)) - ihs_limit = ihs_org + (ihs_size - 2*IHSGETA); - else - error("can't reset ihs_limit."); #ifdef DOWN_STACK if (&narg > cs_org - cssize + 16) cs_limit = cs_org - cssize; @@ -351,10 +384,8 @@ alloc_stacks(int *new_cs_org) bds_org = alloc(bds_size * sizeof(*bds_org)); bds_top = bds_org-1; bds_limit = &bds_org[bds_size - 2*BDSGETA]; - ihs_size = IHSSIZE + 2*IHSGETA; - ihs_org = alloc(ihs_size * sizeof(*ihs_org)); - ihs_top = ihs_org-1; - ihs_limit = &ihs_org[ihs_size - 2*IHSGETA]; + + ihs_top = 0; cs_org = new_cs_org; #if defined(HAVE_SYS_RESOURCE_H) && defined(RLIMIT_STACK) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index dc2408d31..d8922f173 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -161,7 +161,7 @@ (let* #-:CCL ((sys::*ihs-base* sys::*ihs-top*) - (sys::*ihs-top* (1- (sys::ihs-top))) + (sys::*ihs-top* (sys::ihs-top 'cmp-toplevel-eval)) (*break-enable* *compiler-break-enable*) (sys::*break-hidden-packages* (cons (find-package 'compiler) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index e8755cd89..4c32eed42 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -261,7 +261,7 @@ #-clcs (CERROR (T T *) T nil nil) -(si::IHS-TOP) +(si::IHS-TOP (T) T) (si::IHS-FUN) (si::IHS-ENV) (si::FRS-TOP) diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 4df904391..d1456caae 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -10,6 +10,20 @@ OP_PUSH Pushes the object in VALUES(0) + OP_PUSHV n{arg}, var{symbol} + Pushes the value of the n-th local onto the stack. VAR is given + for readability purposes only. + + 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_VARS var{symbol} + Returns the value of the symbol VAR. + OP_PUSHQ value{obj} Pushes "value" @@ -103,7 +117,10 @@ enum { OP_PUSH, OP_PUSHQ, OP_PUSHV, + OP_PUSHVS, OP_PUSHVALUES, + OP_VAR, + OP_VARS, OP_MCALL, OP_CALL, OP_FCALL, diff --git a/src/h/config.h.in b/src/h/config.h.in index 98988ce83..ffc53504a 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -44,8 +44,6 @@ #define MAXPAGE 16384 /* Maximum Memory Size */ #define BDSSIZE 2048 /* Size of Binding Stack */ #define BDSGETA 16 /* Safety zone of BDS */ -#define IHSSIZE 1024 /* Size of Invocation History Stack */ -#define IHSGETA 32 /* Safety zone of IHS */ #define FRSSIZE 1024 /* Size of Frame Stack */ #define FRSGETA 16 /* Safety zone of FRS */ #ifdef THREADS diff --git a/src/h/external.h b/src/h/external.h index 832b0f783..0906862be 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -193,14 +193,13 @@ extern void check_other_key(cl_object l, int n, ...); /* compiler.c */ -cl_object make_lambda(cl_object name, cl_object lambda); -cl_object eval(cl_object form, cl_object *bytecodes, cl_object env); +extern cl_object make_lambda(cl_object name, cl_object lambda); +extern cl_object eval(cl_object form, cl_object *bytecodes, cl_object env); /* interpreter.c */ -cl_object stack; -cl_object lambda_apply(int narg, cl_object fun, cl_object *args); -cl_object *interpret(cl_object *memory); +extern cl_object lambda_apply(int narg, cl_object fun, cl_object *args); +extern cl_object *interpret(cl_object *memory); /* conditional.c */ @@ -383,7 +382,6 @@ extern void init_let(void); /* lex.c */ extern void lex_fun_bind(cl_object name, cl_object fun); -extern void lex_macro_bind(cl_object name, cl_object exp_fun); extern void lex_tag_bind(cl_object tag, cl_object id); extern void lex_block_bind(cl_object name, cl_object id); extern cl_object lex_sch(cl_object lex_list, cl_object name, cl_object type); @@ -665,10 +663,7 @@ extern void (*write_ch_fun)(); extern void (*output_ch_fun)(); extern cl_object PRINTpackage; extern bool PRINTstructure; -extern cl_index CIRCLEsize; -extern cl_object *CIRCLEbase; -extern cl_object *CIRCLEtop; -extern cl_object *CIRCLElimit; +extern cl_fixnum CIRCLEbase; extern cl_object PRINTstream; extern void interactive_writec_stream(int c, cl_object stream); extern void flush_interactive_stream(cl_object stream); @@ -764,9 +759,6 @@ extern void init_sequence(void); extern void bds_overflow(void) __attribute__((noreturn)); extern void bds_unwind(bds_ptr new_bds_top); -extern void ihs_overflow(void) __attribute__((noreturn)); -extern cl_object ihs_function_name(cl_object x); -extern cl_object ihs_top_function_name(void); extern int frs_overflow(void) __attribute__((noreturn)); extern void unwind(frame_ptr fr, cl_object tag) __attribute__((noreturn)); extern frame_ptr frs_sch(cl_object frame_id); diff --git a/src/h/lisp_external.h b/src/h/lisp_external.h index 3f549a35b..c31610fa2 100644 --- a/src/h/lisp_external.h +++ b/src/h/lisp_external.h @@ -820,9 +820,11 @@ extern cl_object clLnreverse _ARGS((int narg, cl_object x)); /* stacks.c */ extern cl_object Kcatch, Kcatchall, Kprotect; -extern cl_object siLihs_top _ARGS((int narg)); +extern cl_object siLihs_top _ARGS((int narg, cl_object arg)); extern cl_object siLihs_fun _ARGS((int narg, cl_object arg)); extern cl_object siLihs_env _ARGS((int narg, cl_object arg)); +extern cl_object siLihs_next _ARGS((int narg, cl_object arg)); +extern cl_object siLihs_prev _ARGS((int narg, cl_object arg)); extern cl_object siLfrs_top _ARGS((int narg)); extern cl_object siLfrs_bds _ARGS((int narg, cl_object arg)); extern cl_object siLfrs_class _ARGS((int narg, cl_object arg)); diff --git a/src/h/lwp.h b/src/h/lwp.h index 121c2f366..55cb1eefb 100644 --- a/src/h/lwp.h +++ b/src/h/lwp.h @@ -92,10 +92,7 @@ typedef struct lpd { int lwp_intern_flag; /* print.d */ - jmp_buf lwp_CIRCLEjmp; - cl_object *lwp_CIRCLEbase; - cl_object *lwp_CIRCLEtop; - cl_object *lwp_CIRCLElimit; + cl_fixnum lwp_CIRCLEbase; cl_object lwp_PRINTstream; bool lwp_PRINTescape; bool lwp_PRINTpretty; diff --git a/src/h/stacks.h b/src/h/stacks.h index 7531ffa33..ee6c23c96 100644 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -17,7 +17,19 @@ * INTERPRETER STACK ********************/ -extern cl_object stack; +extern cl_index cl_stack_size; +extern cl_object *cl_stack; +extern cl_object *cl_stack_top; +extern cl_object *cl_stack_limit; + +extern void cl_stack_push(cl_object o); +extern cl_object cl_stack_pop(); +extern cl_index cl_stack_index(); +extern void cl_stack_set_index(cl_index sp); +extern void cl_stack_pop_n(cl_index n); +extern void cl_stack_insert(cl_index where, cl_index n); +extern void cl_stack_push_varargs(cl_index n, va_list args); +extern void cl_stack_push_n(cl_index n, cl_object *args); /************** * BIND STACK @@ -60,59 +72,11 @@ extern bds_ptr bds_top; /* bind stack top */ * INVOCATION HISTORY STACK ****************************/ -typedef struct invocation_history { - cl_object ihs_function; - cl_object ihs_base; -} *ihs_ptr; +cl_index ihs_top; -#ifdef THREADS -#define ihs_size clwp->lwp_ihs_size -#define ihs_org clwp->lwp_ihs_org -#define ihs_limit clwp->lwp_ihs_limit -#define ihs_top clwp->lwp_ihs_top -#else -extern size_t ihs_size; -extern ihs_ptr ihs_org; -extern ihs_ptr ihs_limit; -extern ihs_ptr ihs_top; -#endif -#define ihs_stack ihs_org - -#define ihs_check \ - if (ihs_top >= ihs_limit) \ - ihs_overflow() - -#define ihs_push(function, args) { \ - (++ihs_top)->ihs_function = (function); \ - ihs_top->ihs_base = args; \ -} - -#define ihs_push_funcall(function) { \ - ihs_check; \ - (++ihs_top)->ihs_function = (function); \ - ihs_top->ihs_base = Cnil; \ -} - -#define ihs_pop() (ihs_top--) - -#define make_nil_block(r) { \ - cl_object x; \ - lex_copy(); \ - x = new_frame_id(); \ - lex_block_bind(Cnil, x); \ - r = frs_push(FRS_CATCH, x); \ -} - -#define BLOCK(name,output) { \ - cl_object *lex_old = lex_env; lex_dcl; \ - cl_object _x; \ - lex_copy(); \ - _x = new_frame_id(); \ - lex_block_bind(name,_x); \ - if (frs_push(FRS_CATCH,_x) != 0) output = Values[0]; else -#define END_BLOCK \ - frs_pop(); \ - lex_env = lex_old; } +extern void ihs_push(cl_object fun, cl_object env); +extern cl_object ihs_top_function_name(); +extern void ihs_pop(); /*************** * FRAME STACK @@ -143,7 +107,7 @@ typedef struct frame { bds_ptr frs_bds_top; enum fr_class frs_class; cl_object frs_val; - ihs_ptr frs_ihs; + cl_index frs_ihs; cl_index frs_sp; } *frame_ptr; @@ -267,7 +231,6 @@ extern cl_object lex_env; #define lex_copy() lex_env = CONS(car(lex_env),cdr(lex_env)) #define lex_new() lex_env = CONS(Cnil,Cnil) -#define lex_var_sch(name) assq((name),CAR(lex_env)) #define lex_fun_sch(name) lex_sch(CDR(lex_env),(name),clSfunction) #define lex_tag_sch(name) lex_sch(CDR(lex_env),(name),clStag) #define lex_block_sch(name) lex_sch(CDR(lex_env),(name),clSblock) diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index e34744c17..614637540 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -42,7 +42,7 @@ (defvar *break-level* 0) ; nesting level of error loops (defvar *break-env* nil) (defvar *ihs-base* 0) -(defvar *ihs-top* 0) +(defvar *ihs-top* (ihs-top 'si::top-level)) (defvar *ihs-current* 0) (defvar *frs-base* 0) (defvar *frs-top* 0) @@ -425,7 +425,6 @@ Usage: ecls [-dir dir] [-load file] [-eval expr] (setq *lisp-initialized* t)) (in-package "CL-USER") - (setq sys::*gc-verbose* t) (catch *quit-tag* (let ((*tpl-level* -1)) @@ -442,7 +441,7 @@ Usage: ecls [-dir dir] [-load file] [-eval expr] ((:prompt-hook *tpl-prompt-hook*) nil) (quiet nil)) (let* ((*ihs-base* *ihs-top*) - (*ihs-top* (ihs-top)) + (*ihs-top* (ihs-top 'tpl)) (*ihs-current* *ihs-top*) (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) (*frs-top* (frs-top)) @@ -581,7 +580,7 @@ Usage: ecls [-dir dir] [-load file] [-eval expr] (tpl-print-current)) (defun tpl-previous (&optional (n 1)) - (do ((i (1- *ihs-current*) (1- i))) + (do ((i (si::ihs-prev *ihs-current*) (si::ihs-prev i))) ((or (< i *ihs-base*) (<= n 0))) (when (ihs-visible i) (setq *ihs-current* i) @@ -590,7 +589,7 @@ Usage: ecls [-dir dir] [-load file] [-eval expr] (tpl-print-current)) (defun tpl-next (&optional (n 1)) - (do ((i (1+ *ihs-current*) (1+ i))) + (do ((i (si::ihs-next *ihs-current*) (si::ihs-next i))) ((or (> i *ihs-top*) (<= n 0))) (when (ihs-visible i) (setq *ihs-current* i) @@ -616,70 +615,24 @@ Usage: ecls [-dir dir] [-load file] [-eval expr] (*print-pretty* t) (fun (ihs-fun *ihs-current*)) name args) - (if (and (compiled-function-p fun) - (symbolp (setq name (compiled-function-name fun))) - (setq args (get name 'arglist))) - (progn -#| - (format t - "Local variables:~%") - (do ((args args (cdr args)) - (i (ihs-vs *ihs-current*) (1+ i))) - ((null args)) - (declare (fixnum i)) - (format t "~:[~s: ~s~;~s~]~%" no-values (car args) (vs i))) -|# -) - (apply #'format t - "Local variables:~#[~; none~:;~:[ ~1{~s~}~:@{, ~s~}~;~ - ~:@{~% ~s: ~s~}~]~]~%" - (not no-values) (car *break-env*))) - (apply #'format t - "~#[~:;Local functions: ~@{~s~^, ~}.~%~]" + (format t + "~:[~;Local functions: ~:*~{~s~^, ~}.~%~]" (mapcan #'(lambda (x) (and (eq (second x) 'FUNCTION) (list (car x)))) (cdr *break-env*))) - (apply #'format t - "~#[~:;Block names: ~@{~s~^, ~}.~%~]" + (format t + "~:[~;Block names: ~:*~{~s~^, ~}.~%~]" (mapcan #'(lambda (x) (and (eq (second x) 'BLOCK) (list (car x)))) (cdr *break-env*))) - (apply #'format t - "~#[~:;Tags: ~@{~s~^, ~}.~%~]" + (format t + "~:[~;Tags: ~:*~{~s~^, ~}.~%~]" (mapcan #'(lambda (x) (when (eq (second x) 'TAG) (list (car x)))) (cdr *break-env*))) + (format t + "Local variables:~:[ ~:[none~;~:*~{~s~1*~:@{, ~s~1*~}~}~]~;~ + ~:[ none~;~:*~{~% ~s: ~s~}~]~]~%" + (not no-values) (car *break-env*))) (values))) -#| -(defun tpl-vs-command (&optional x) - (let ((min (ihs-vs *ihs-base*)) - (max (1- (ihs-vs (1+ *ihs-top*)))) - y) - (cond ((integerp x) - (if (and (>= x min) (<= x max)) - (vs x) - (format t "Illegal value stack index.~%"))) - ((null x) - (setq x min) - (setq y max) - (do ((ii *ihs-base* (1+ ii)) - (*print-level* 2) - (*print-length* 4) - (*print-pretty* t)) - ((or (>= ii *ihs-top*) (>= (ihs-vs ii) x)) - (do ((vi x (1+ vi))) - ((> vi y)) - (do () - ((> (ihs-vs ii) vi)) - (when (ihs-visible ii) - (print-ihs ii)) - (incf ii)) - (format t " VS[~d]: ~s~%" vi (vs vi))))) - (values)) - (t - (format t "Argument must be a number.~%") - (values))))) -(defun tpl-local-command (&optional (n 0)) - (tpl-vs-command (+ (ihs-vs *ihs-current*) n))) -|# (defun tpl-bds-command (&optional var) (if var (do ((bi (1+ (frs-bds (max 0 (1- *frs-base*)))) (1+ bi)) @@ -708,23 +661,20 @@ Usage: ecls [-dir dir] [-load file] [-eval expr] (let ((*print-pretty* nil)) ; because CLOS allows (setf foo) ; as function names (princ "Backtrace:") - (do ((i *ihs-base* (1+ i)) + (do ((i *ihs-top* (si::ihs-prev i)) (b nil t)) - ((> i *ihs-top*)) + ((< i *ihs-base*)) (when (ihs-visible i) (let ((*print-case* (if (= i *ihs-current*) :UPCASE :DOWNCASE))) (format t "~:[~; >~] ~S" b (ihs-fname i))))) (terpri)) - (let ((from (if (integerp n) - (max (1+ (- *ihs-current* n)) *ihs-base*) - *ihs-base*)) - (to (if (integerp n) *ihs-current* *ihs-top*))) - (do ((i from (1+ i)) - (j (or (sch-frs-base *frs-base* from) (1+ *frs-top*))) - (*print-level* 2) - (*print-length* 4) - (*print-pretty* t)) - ((> i to) (values)) + (do ((i *ihs-top* (si::ihs-prev i)) + (k (if (integerp n) n Cnil) (and k (1- k)))) + ((= k 0) (values)) + (let ((j (or (sch-frs-base *frs-base* i) (1+ *frs-top*))) + (*print-level* 2) + (*print-length* 4) + (*print-pretty* t)) (when (ihs-visible i) (print-ihs i)) (do () ((or (> j *frs-top*) (> (frs-ihs j) i))) @@ -732,55 +682,10 @@ Usage: ecls [-dir dir] [-load file] [-eval expr] (incf j))))) (values)) -#| -(defun print-ihs (i) - (format t "~:[ ~;@ ~]IHS[~d]: ~s ---> VS[~d]~%" - (= i *ihs-current*) i - (let ((fun (ihs-fun i))) - (cond ((or (symbolp fun) (compiled-function-p fun)) fun) - ((consp fun) - (case (car fun) - (lambda fun) - (lambda-block (cdr fun)) - (lambda-closure (cons 'lambda (cddddr fun))) - (lambda-block-closure (cddddr fun)) - #+clos - (setf fun) - (t '(:zombi)))) - #+clos - ((sys:gfunp fun) fun) - (t :zombi))) - (ihs-vs i))) -|# - (defun print-frs (i) (format *debug-io* " FRS[~d]: ---> IHS[~d],BDS[~d]~%" i (frs-ihs i) (frs-bds i))) -#| -(defun print-frs (i) - (format *debug-io* "~& FRS[~d]: ~s ---> IHS[~d],VS[~d],BDS[~d]" - i (frs-kind i) (frs-ihs i) (frs-vs i) (frs-bds i))) - -(defun frs-kind (i &aux x) - (case (frs-class i) - (:catch - (if (spicep (frs-tag i)) - (or (and (setq x (member (frs-tag i) (vs (+ (frs-vs i) 2)) - :key #'third :test #'eq)) - (if (eq (cadar x) 'block) - `(block ,(caar x) ***) - `(tagbody - ,@(reverse - (mapcar #'car (remove (frs-tag i) x :test-not #'eq - :key #'third))) - ***))) - `(block/tagbody ,(frs-tag i))) - `(catch ',(frs-tag i) ***))) - (:protect '(unwind-protect ***)) - (t `(system-internal-catcher ,(frs-tag i))))) -|# - (defun break-where (&aux (fname (ihs-fname *ihs-current*))) (if (or (eq fname 'TOP-LEVEL) (eq fname 'BREAK-WHERE)) (format t "Top level.~%") @@ -842,16 +747,16 @@ Usage: ecls [-dir dir] [-load file] [-eval expr] (t :zombi)))) (defun set-current-ihs () - (do ((i *ihs-current* (1- i))) + (do ((i *ihs-current* (si::ihs-prev i))) ((or (and (ihs-visible i) (setq *ihs-current* i)) (<= i *ihs-base*)))) (set-break-env)) (defun set-break-env () - (setq *break-env* (ihs-env *ihs-current*))) + (setq *break-env* (if (= *ihs-current* *ihs-top*) nil (ihs-env *ihs-current*)))) (defun tpl-backward-search (string) - (do ((ihs (1- *ihs-current*) (1- ihs))) + (do ((ihs (si::ihs-prev *ihs-current*) (si::ihs-prev ihs))) ((< ihs *ihs-base*) (format *debug-io* "Search for ~a failed.~%" string)) (when (and (ihs-visible ihs) @@ -864,7 +769,7 @@ Usage: ecls [-dir dir] [-load file] [-eval expr] (values)) (defun tpl-forward-search (string) - (do ((ihs (1+ *ihs-current*) (1+ ihs))) + (do ((ihs (si::ihs-next *ihs-current*) (si::ihs-next ihs))) ((> ihs *ihs-top*) (format *debug-io* "Search for ~a failed.~%" string)) (when (and (ihs-visible ihs)