X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/d9df6f40e326f3f5487b7c50b99bf5112262badc..844e0de1bc2bf56118b749f50a4880db7c918fd5:/src/bytecode.c diff --git a/src/bytecode.c b/src/bytecode.c index acb96c1e61..7e7063e131 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1,5 +1,5 @@ /* Execution of byte code produced by bytecomp.el. - Copyright (C) 1985-1988, 1993, 2000-2013 Free Software Foundation, + Copyright (C) 1985-1988, 1993, 2000-2014 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -59,7 +59,8 @@ by Hallvard: indirect threaded, using GCC's computed goto extension. This code, as currently implemented, is incompatible with BYTE_CODE_SAFE and BYTE_CODE_METER. */ -#if defined (__GNUC__) && !defined (BYTE_CODE_SAFE) && !defined (BYTE_CODE_METER) +#if (defined __GNUC__ && !defined __STRICT_ANSI__ \ + && !defined BYTE_CODE_SAFE && !defined BYTE_CODE_METER) #define BYTE_CODE_THREADED #endif @@ -140,6 +141,10 @@ DEFINE (Bunbind5, 055) \ DEFINE (Bunbind6, 056) \ DEFINE (Bunbind7, 057) \ \ +DEFINE (Bpophandler, 060) \ +DEFINE (Bpushconditioncase, 061) \ +DEFINE (Bpushcatch, 062) \ + \ DEFINE (Bnth, 070) \ DEFINE (Bsymbolp, 071) \ DEFINE (Bconsp, 072) \ @@ -285,12 +290,9 @@ enum byte_code_op #ifdef BYTE_CODE_SAFE Bscan_buffer = 0153, /* No longer generated as of v18. */ - Bset_mark = 0163 /* this loser is no longer generated as of v18 */ + Bset_mark = 0163, /* this loser is no longer generated as of v18 */ #endif }; - -/* Whether to maintain a `top' and `bottom' field in the stack frame. */ -#define BYTE_MAINTAIN_TOP (BYTE_CODE_SAFE || BYTE_MARK_STACK) /* Structure describing a value stack used during byte-code execution in Fbyte_code. */ @@ -301,12 +303,6 @@ struct byte_stack and is relocated when that string is relocated. */ const unsigned char *pc; - /* Top and bottom of stack. The bottom points to an area of memory - allocated with alloca in Fbyte_code. */ -#if BYTE_MAINTAIN_TOP - Lisp_Object *top, *bottom; -#endif - /* The string containing the byte-code, and its current address. Storing this here protects it from GC because mark_byte_stack marks it. */ @@ -318,72 +314,15 @@ struct byte_stack this here protects it from GC because mark_byte_stack marks it. */ Lisp_Object constants; #endif - - /* Next entry in byte_stack_list. */ - struct byte_stack *next; }; - -/* A list of currently active byte-code execution value stacks. - Fbyte_code adds an entry to the head of this list before it starts - processing byte-code, and it removed the entry again when it is - done. Signaling an error truncates the list analogous to - gcprolist. */ - -struct byte_stack *byte_stack_list; - - -/* Mark objects on byte_stack_list. Called during GC. */ - -#if BYTE_MARK_STACK -void -mark_byte_stack (void) -{ - struct byte_stack *stack; - Lisp_Object *obj; - - for (stack = byte_stack_list; stack; stack = stack->next) - { - /* If STACK->top is null here, this means there's an opcode in - Fbyte_code that wasn't expected to GC, but did. To find out - which opcode this is, record the value of `stack', and walk - up the stack in a debugger, stopping in frames of Fbyte_code. - The culprit is found in the frame of Fbyte_code where the - address of its local variable `stack' is equal to the - recorded value of `stack' here. */ - eassert (stack->top); - - for (obj = stack->bottom; obj <= stack->top; ++obj) - mark_object (*obj); - - mark_object (stack->byte_string); - mark_object (stack->constants); - } -} -#endif - -/* Unmark objects in the stacks on byte_stack_list. Relocate program - counters. Called when GC has completed. */ - -void -unmark_byte_stack (void) -{ - struct byte_stack *stack; - - for (stack = byte_stack_list; stack; stack = stack->next) - { - if (stack->byte_string_start != SDATA (stack->byte_string)) - { - ptrdiff_t offset = stack->pc - stack->byte_string_start; - stack->byte_string_start = SDATA (stack->byte_string); - stack->pc = stack->byte_string_start + offset; - } - } -} - /* Fetch the next byte from the bytecode stream. */ +#ifdef BYTE_CODE_SAFE +#define FETCH (eassert (stack.byte_string_start == SDATA (stack.byte_string)), *stack.pc++) +#else #define FETCH *stack.pc++ +#endif /* Fetch two bytes from the bytecode stream and make a 16-bit number out of them. */ @@ -413,13 +352,8 @@ unmark_byte_stack (void) /* Actions that must be performed before and after calling a function that might GC. */ -#if !BYTE_MAINTAIN_TOP #define BEFORE_POTENTIAL_GC() ((void)0) #define AFTER_POTENTIAL_GC() ((void)0) -#else -#define BEFORE_POTENTIAL_GC() stack.top = top -#define AFTER_POTENTIAL_GC() stack.top = NULL -#endif /* Garbage collect if we have consed enough since the last time. We do this at every branch, to avoid loops that never GC. */ @@ -475,6 +409,12 @@ If the third argument is incorrect, Emacs may crash. */) return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL); } +static void +bcall0 (Lisp_Object f) +{ + Ffuncall (1, &f); +} + /* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect, emacs may crash!). If ARGS_TEMPLATE is non-nil, it should be a lisp @@ -483,13 +423,14 @@ If the third argument is incorrect, Emacs may crash. */) ARGS are pushed on the stack according to ARGS_TEMPLATE before executing BYTESTR. */ +/* {{coccinelle:skip_start}} */ Lisp_Object exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object args_template, ptrdiff_t nargs, Lisp_Object *args) { ptrdiff_t count = SPECPDL_INDEX (); #ifdef BYTE_CODE_METER - int this_op = 0; + int volatile this_op = 0; int prev_op; #endif int op; @@ -503,6 +444,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, struct byte_stack stack; Lisp_Object *top; Lisp_Object result; + enum handlertype type; #if 0 /* CHECK_FRAME_FONT */ { @@ -543,12 +485,6 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, if (MAX_ALLOCA / word_size <= XFASTINT (maxdepth)) memory_full (SIZE_MAX); top = alloca ((XFASTINT (maxdepth) + 1) * sizeof *top); -#if BYTE_MAINTAIN_TOP - stack.bottom = top + 1; - stack.top = NULL; -#endif - stack.next = byte_stack_list; - byte_stack_list = &stack; #ifdef BYTE_CODE_SAFE stacke = stack.bottom - 1 + XFASTINT (maxdepth); @@ -569,9 +505,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, if (nargs < mandatory) /* Too few arguments. */ Fsignal (Qwrong_number_of_arguments, - Fcons (Fcons (make_number (mandatory), + list2 (Fcons (make_number (mandatory), rest ? Qand_rest : make_number (nonrest)), - Fcons (make_number (nargs), Qnil))); + make_number (nargs))); else { for (; i < nonrest; i++) @@ -590,9 +526,8 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, else /* Too many arguments. */ Fsignal (Qwrong_number_of_arguments, - Fcons (Fcons (make_number (mandatory), - make_number (nonrest)), - Fcons (make_number (nargs), Qnil))); + list2 (Fcons (make_number (mandatory), make_number (nonrest)), + make_number (nargs))); } else if (! NILP (args_template)) /* We should push some arguments on the stack. */ @@ -660,9 +595,12 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, the table clearer. */ #define LABEL(OP) [OP] = &&insn_ ## OP -#if (__GNUC__ == 4 && 6 <= __GNUC_MINOR__) || 4 < __GNUC__ +#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) # pragma GCC diagnostic push # pragma GCC diagnostic ignored "-Woverride-init" +#elif defined __clang__ +# pragma GCC diagnostic push +# pragma GCC diagnostic ignored "-Winitializer-overrides" #endif /* This is the dispatch table for the threaded interpreter. */ @@ -676,7 +614,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, #undef DEFINE }; -#if (__GNUC__ == 4 && 6 <= __GNUC_MINOR__) || 4 < __GNUC__ +#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) || defined __clang__ # pragma GCC diagnostic pop #endif @@ -709,7 +647,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, v1 = vectorp[op]; if (SYMBOLP (v1)) { - if (XSYMBOL (v1)->redirect != SYMBOL_PLAINVAL + if (SYMBOL_REDIRECT (XSYMBOL (v1)) != SYMBOL_PLAINVAL || (v2 = SYMBOL_VAL (XSYMBOL (v1)), EQ (v2, Qunbound))) { @@ -818,7 +756,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, /* Inline the most common case. */ if (SYMBOLP (sym) && !EQ (val, Qunbound) - && !XSYMBOL (sym)->redirect + && !SYMBOL_REDIRECT (XSYMBOL (sym)) && !SYMBOL_CONSTANT_P (sym)) SET_SYMBOL_VAL (XSYMBOL (sym), val); else @@ -859,6 +797,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, varbind: /* Specbind can signal and thus GC. */ BEFORE_POTENTIAL_GC (); + dynwind_begin (); specbind (vectorp[op], POP); AFTER_POTENTIAL_GC (); NEXT; @@ -919,16 +858,13 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, op -= Bunbind; dounbind: BEFORE_POTENTIAL_GC (); - unbind_to (SPECPDL_INDEX () - op, Qnil); + for (int i = 0; i < op; i++) + dynwind_end (); AFTER_POTENTIAL_GC (); NEXT; CASE (Bunbind_all): /* Obsolete. Never used. */ - /* To unbind back to the beginning of this frame. Not used yet, - but will be needed for tail-recursion elimination. */ - BEFORE_POTENTIAL_GC (); - unbind_to (count, Qnil); - AFTER_POTENTIAL_GC (); + emacs_abort (); NEXT; CASE (Bgoto): @@ -1047,33 +983,36 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; CASE (Bsave_excursion): + dynwind_begin (); record_unwind_protect (save_excursion_restore, save_excursion_save ()); NEXT; CASE (Bsave_current_buffer): /* Obsolete since ??. */ CASE (Bsave_current_buffer_1): + dynwind_begin (); record_unwind_current_buffer (); NEXT; CASE (Bsave_window_excursion): /* Obsolete since 24.1. */ { - register ptrdiff_t count1 = SPECPDL_INDEX (); - record_unwind_protect (Fset_window_configuration, + dynwind_begin (); + record_unwind_protect (restore_window_configuration, Fcurrent_window_configuration (Qnil)); BEFORE_POTENTIAL_GC (); TOP = Fprogn (TOP); - unbind_to (count1, TOP); + dynwind_end (); AFTER_POTENTIAL_GC (); NEXT; } CASE (Bsave_restriction): + dynwind_begin (); record_unwind_protect (save_restriction_restore, save_restriction_save ()); NEXT; - CASE (Bcatch): /* FIXME: ill-suited for lexbind. */ + CASE (Bcatch): /* Obsolete since 24.4. */ { Lisp_Object v1; BEFORE_POTENTIAL_GC (); @@ -1083,11 +1022,30 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; } + CASE (Bpushcatch): /* New in 24.4. */ + emacs_abort (); + NEXT; + + CASE (Bpushconditioncase): /* New in 24.4. */ + emacs_abort (); + NEXT; + + CASE (Bpophandler): /* New in 24.4. */ + emacs_abort (); + NEXT; + CASE (Bunwind_protect): /* FIXME: avoid closure for lexbind. */ - record_unwind_protect (Fprogn, POP); - NEXT; + { + Lisp_Object handler = POP; + dynwind_begin (); + /* Support for a function here is new in 24.4. */ + record_unwind_protect (NILP (Ffunctionp (handler)) + ? unwind_body : bcall0, + handler); + NEXT; + } - CASE (Bcondition_case): /* FIXME: ill-suited for lexbind. */ + CASE (Bcondition_case): /* Obsolete since 24.4. */ { Lisp_Object handlers, body; handlers = POP; @@ -1101,6 +1059,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Btemp_output_buffer_setup): /* Obsolete since 24.1. */ BEFORE_POTENTIAL_GC (); CHECK_STRING (TOP); + dynwind_begin (); temp_output_buffer_setup (SSDATA (TOP)); AFTER_POTENTIAL_GC (); TOP = Vstandard_output; @@ -1114,7 +1073,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, temp_output_buffer_show (TOP); TOP = v1; /* pop binding of standard-output */ - unbind_to (SPECPDL_INDEX () - 1, Qnil); + dynwind_end (); AFTER_POTENTIAL_GC (); NEXT; } @@ -1166,14 +1125,14 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, } CASE (Blist1): - TOP = Fcons (TOP, Qnil); + TOP = list1 (TOP); NEXT; CASE (Blist2): { Lisp_Object v1; v1 = POP; - TOP = Fcons (TOP, Fcons (v1, Qnil)); + TOP = list2 (TOP, v1); NEXT; } @@ -1362,7 +1321,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1; BEFORE_POTENTIAL_GC (); v1 = POP; - TOP = Fgtr (TOP, v1); + TOP = arithcompare (TOP, v1, ARITH_GRTR); AFTER_POTENTIAL_GC (); NEXT; } @@ -1372,7 +1331,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1; BEFORE_POTENTIAL_GC (); v1 = POP; - TOP = Flss (TOP, v1); + TOP = arithcompare (TOP, v1, ARITH_LESS); AFTER_POTENTIAL_GC (); NEXT; } @@ -1382,7 +1341,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1; BEFORE_POTENTIAL_GC (); v1 = POP; - TOP = Fleq (TOP, v1); + TOP = arithcompare (TOP, v1, ARITH_LESS_OR_EQUAL); AFTER_POTENTIAL_GC (); NEXT; } @@ -1392,7 +1351,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1; BEFORE_POTENTIAL_GC (); v1 = POP; - TOP = Fgeq (TOP, v1); + TOP = arithcompare (TOP, v1, ARITH_GRTR_OR_EQUAL); AFTER_POTENTIAL_GC (); NEXT; } @@ -1633,7 +1592,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, c = XFASTINT (TOP); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) MAKE_CHAR_MULTIBYTE (c); - XSETFASTINT (TOP, syntax_code_spec[(int) SYNTAX (c)]); + XSETFASTINT (TOP, syntax_code_spec[SYNTAX (c)]); } NEXT; @@ -1879,7 +1838,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, /* Actually this is Bstack_ref with offset 0, but we use Bdup for that instead. */ /* CASE (Bstack_ref): */ - error ("Invalid byte opcode"); + call3 (intern ("error"), + build_string ("Invalid byte opcode: op=%s, ptr=%d"), + make_number (op), + make_number ((stack.pc - 1) - stack.byte_string_start)); /* Handy byte-codes for lexical binding. */ CASE (Bstack_ref1): @@ -1947,24 +1909,14 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, } exit: - - byte_stack_list = byte_stack_list->next; - - /* Binds and unbinds are supposed to be compiled balanced. */ - if (SPECPDL_INDEX () != count) -#ifdef BYTE_CODE_SAFE - error ("binding stack not balanced (serious byte compiler bug)"); -#else - emacs_abort (); -#endif - return result; } +/* {{coccinelle:skip_end}} */ void syms_of_bytecode (void) { - defsubr (&Sbyte_code); +#include "bytecode.x" #ifdef BYTE_CODE_METER