diff options
| -rw-r--r-- | src/bytecode.c | 91 | ||||
| -rw-r--r-- | src/eval.c | 37 | ||||
| -rw-r--r-- | src/lisp.h | 5 |
3 files changed, 116 insertions, 17 deletions
diff --git a/src/bytecode.c b/src/bytecode.c index 29b76f88ef7..fe59cf6600b 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -311,8 +311,6 @@ enum byte_code_op #define TOP (*top) -#define UPDATE_OFFSET (backtrace_byte_offset = pc - bytestr_data); - DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0, doc: /* Function used internally in byte-compiled code. The first argument, BYTESTR, is a string of byte code; @@ -433,7 +431,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, /* NEXT is invoked at the end of an instruction to go to the next instruction. It is either a computed goto, or a plain break. */ -#define NEXT UPDATE_OFFSET goto *(targets[op = FETCH]) +#define NEXT goto *(targets[op = FETCH]) /* FIRST is like NEXT, but is only used at the start of the interpreter body. In the switch-based interpreter it is the switch, so the threaded definition must include a semicolon. */ @@ -635,7 +633,90 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, } } #endif - TOP = Ffuncall (op + 1, &TOP); + Lisp_Object fun, original_fun; + Lisp_Object funcar; + Lisp_Object *fun_args; + ptrdiff_t numargs = op; + Lisp_Object val; + ptrdiff_t count_c; + + maybe_quit (); + + if (++lisp_eval_depth > max_lisp_eval_depth) + { + if (max_lisp_eval_depth < 100) + max_lisp_eval_depth = 100; + if (lisp_eval_depth > max_lisp_eval_depth) + error ("Lisp nesting exceeds `max-lisp-eval-depth'"); + } + + fun_args = &TOP + 1; + + count_c = record_in_backtrace_with_offset (TOP, fun_args, numargs, pc - bytestr_data - 1); + + maybe_gc (); + + if (debug_on_next_call) + do_debug_on_call (Qlambda, count); + + original_fun = TOP; + + retry: + + /* Optimize for no indirection. */ + fun = original_fun; + if (SYMBOLP (fun) && !NILP (fun) + && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun))) + fun = indirect_function (fun); + + if (COMPILEDP (fun)) + { + Lisp_Object syms_left = AREF (fun, COMPILED_ARGLIST); + if (FIXNUMP (syms_left)) + { + if (CONSP (AREF (fun, COMPILED_BYTECODE))) + Ffetch_bytecode (fun); + val = exec_byte_code (AREF (fun, COMPILED_BYTECODE), + AREF (fun, COMPILED_CONSTANTS), + AREF (fun, COMPILED_STACK_DEPTH), + syms_left, numargs, fun_args); + } + else + { + /* The rest of funcall_lambda is very bulky */ + val = funcall_lambda (fun, numargs, fun_args); + } + } + else if (SUBRP (fun)) + val = funcall_subr (XSUBR (fun), numargs, fun_args); +#ifdef HAVE_MODULES + else if (MODULE_FUNCTIONP (fun)) + val = funcall_module (fun, numargs, fun_args); +#endif + else + { + if (NILP (fun)) + xsignal1 (Qvoid_function, original_fun); + if (!CONSP (fun) + || (funcar = XCAR (fun), !SYMBOLP(funcar))) + xsignal1 (Qinvalid_function, original_fun); + if (EQ (funcar, Qlambda) + || EQ (funcar, Qclosure)) + val = funcall_lambda (fun, numargs, fun_args); + else if (EQ (funcar, Qautoload)) + { + Fautoload_do_load (fun, original_fun, Qnil); + goto retry; + } + else + xsignal1 (Qinvalid_function, original_fun); + } + lisp_eval_depth--; + if (backtrace_debug_on_exit (specpdl + count_c)) + val = call_debugger (list2 (Qexit, val)); + specpdl_ptr--; + + TOP = val; NEXT; } @@ -1451,7 +1532,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, unbind_to (count, Qnil); error ("binding stack not balanced (serious byte compiler bug)"); } - backtrace_byte_offset = -1; + Lisp_Object result = TOP; SAFE_FREE (); return result; diff --git a/src/eval.c b/src/eval.c index 5b43b81a6ca..544dfc25af9 100644 --- a/src/eval.c +++ b/src/eval.c @@ -56,8 +56,6 @@ Lisp_Object Vrun_hooks; /* FIXME: We should probably get rid of this! */ Lisp_Object Vsignaling_function; -int backtrace_byte_offset = -1; - /* These would ordinarily be static, but they need to be visible to GDB. */ bool backtrace_p (union specbinding *) EXTERNALLY_VISIBLE; Lisp_Object *backtrace_args (union specbinding *) EXTERNALLY_VISIBLE; @@ -65,7 +63,6 @@ Lisp_Object backtrace_function (union specbinding *) EXTERNALLY_VISIBLE; union specbinding *backtrace_next (union specbinding *) EXTERNALLY_VISIBLE; union specbinding *backtrace_top (void) EXTERNALLY_VISIBLE; -static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, ptrdiff_t); static Lisp_Object lambda_arity (Lisp_Object); @@ -146,7 +143,7 @@ backtrace_bytecode_offset (union specbinding *pdl) return pdl->bt.bytecode_offset; } -static bool +bool backtrace_debug_on_exit (union specbinding *pdl) { eassert (pdl->kind == SPECPDL_BACKTRACE); @@ -354,7 +351,7 @@ call_debugger (Lisp_Object arg) return unbind_to (count, val); } -static void +void do_debug_on_call (Lisp_Object code, ptrdiff_t count) { debug_on_next_call = 0; @@ -2146,6 +2143,27 @@ grow_specpdl (void) } ptrdiff_t +record_in_backtrace_with_offset (Lisp_Object function, Lisp_Object *args, + ptrdiff_t nargs, int offset) +{ + ptrdiff_t count = SPECPDL_INDEX (); + + eassert (nargs >= UNEVALLED); + specpdl_ptr->bt.kind = SPECPDL_BACKTRACE; + specpdl_ptr->bt.debug_on_exit = false; + specpdl_ptr->bt.function = function; + current_thread->stack_top = specpdl_ptr->bt.args = args; + specpdl_ptr->bt.nargs = nargs; + specpdl_ptr->bt.bytecode_offset = -1; + union specbinding *nxt = backtrace_top (); + if (backtrace_p (nxt) && nxt->kind == SPECPDL_BACKTRACE) + nxt->bt.bytecode_offset = offset; + grow_specpdl (); + + return count; +} + +ptrdiff_t record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs) { ptrdiff_t count = SPECPDL_INDEX (); @@ -2156,10 +2174,7 @@ record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs) specpdl_ptr->bt.function = function; current_thread->stack_top = specpdl_ptr->bt.args = args; specpdl_ptr->bt.nargs = nargs; - union specbinding *nxt = specpdl_ptr; - nxt = backtrace_next(nxt); - if (nxt->kind == SPECPDL_BACKTRACE) - nxt->bt.bytecode_offset = backtrace_byte_offset; + specpdl_ptr->bt.bytecode_offset = -1; grow_specpdl (); return count; @@ -2965,7 +2980,7 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count) FUN must be either a lambda-expression, a compiled-code object, or a module function. */ -static Lisp_Object +Lisp_Object funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, register Lisp_Object *arg_vector) { @@ -3053,7 +3068,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, arg = Qnil; /* Bind the argument. */ - if (!NILP (lexenv) && SYMBOLP (next)) + if (!NILP (lexenv)) /* Lexically bind NEXT by adding it to the lexenv alist. */ lexenv = Fcons (Fcons (next, arg), lexenv); else diff --git a/src/lisp.h b/src/lisp.h index ef6302a4670..e04e374ca97 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4113,7 +4113,6 @@ extern Lisp_Object Vautoload_queue; extern Lisp_Object Vrun_hooks; extern Lisp_Object Vsignaling_function; extern Lisp_Object inhibit_lisp_code; -extern int backtrace_byte_offset; /* To run a normal hook, use the appropriate function from the list below. The calling convention: @@ -4141,6 +4140,7 @@ extern AVOID signal_error (const char *, Lisp_Object); extern AVOID overflow_error (void); extern bool FUNCTIONP (Lisp_Object); extern Lisp_Object funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *arg_vector); +extern Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); extern Lisp_Object eval_sub (Lisp_Object form); extern Lisp_Object apply1 (Lisp_Object, Lisp_Object); extern Lisp_Object call0 (Lisp_Object); @@ -4185,6 +4185,7 @@ extern Lisp_Object vformat_string (const char *, va_list) ATTRIBUTE_FORMAT_PRINTF (1, 0); extern void un_autoload (Lisp_Object); extern Lisp_Object call_debugger (Lisp_Object arg); +extern void do_debug_on_call (Lisp_Object code, ptrdiff_t count); extern void init_eval_once (void); extern Lisp_Object safe_call (ptrdiff_t, Lisp_Object, ...); extern Lisp_Object safe_call1 (Lisp_Object, Lisp_Object); @@ -4193,8 +4194,10 @@ extern void init_eval (void); extern void syms_of_eval (void); extern void prog_ignore (Lisp_Object); extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t); +extern ptrdiff_t record_in_backtrace_with_offset (Lisp_Object, Lisp_Object *, ptrdiff_t, int); extern void mark_specpdl (union specbinding *first, union specbinding *ptr); extern void get_backtrace (Lisp_Object array); +extern bool backtrace_debug_on_exit (union specbinding *pdl); Lisp_Object backtrace_top_function (void); extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol); |