X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/a9faac5c6333bcbfb30a00debf3de7a44e430e49..fd05c7e9aae3cc636a7e13487dc50010084adae8:/src/bytecode.c diff --git a/src/bytecode.c b/src/bytecode.c index cd6f4a9314..9ed29e94b5 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1,6 +1,5 @@ /* Execution of byte code produced by bytecomp.el. - Copyright (C) 1985, 1986, 1987, 1988, 1993, 2000, 2001, 2002, 2003, 2004, - 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + Copyright (C) 1985-1988, 1993, 2000-2011 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -58,9 +57,7 @@ by Hallvard: #ifdef BYTE_CODE_METER -Lisp_Object Vbyte_code_meter, Qbyte_code_meter; -int byte_metering_on; - +Lisp_Object Qbyte_code_meter; #define METER_2(code1, code2) \ XFASTINT (XVECTOR (XVECTOR (Vbyte_code_meter)->contents[(code1)]) \ ->contents[(code2)]) @@ -79,17 +76,14 @@ int byte_metering_on; } \ } -#else /* no BYTE_CODE_METER */ - -#define METER_CODE(last_code, this_code) - -#endif /* no BYTE_CODE_METER */ +#endif /* BYTE_CODE_METER */ Lisp_Object Qbytecode; /* Byte codes: */ +#define Bstack_ref 0 /* Actually, Bstack_ref+0 is not implemented: use dup. */ #define Bvarref 010 #define Bvarset 020 #define Bvarbind 030 @@ -139,7 +133,7 @@ Lisp_Object Qbytecode; #define Bpoint 0140 /* Was Bmark in v17. */ -#define Bsave_current_buffer 0141 +#define Bsave_current_buffer 0141 /* Obsolete. */ #define Bgoto_char 0142 #define Binsert 0143 #define Bpoint_max 0144 @@ -149,7 +143,9 @@ Lisp_Object Qbytecode; #define Bpreceding_char 0150 #define Bcurrent_column 0151 #define Bindent_to 0152 -#define Bscan_buffer 0153 /* No longer generated as of v18 */ +#ifdef BYTE_CODE_SAFE +#define Bscan_buffer 0153 /* No longer generated as of v18. */ +#endif #define Beolp 0154 #define Beobp 0155 #define Bbolp 0156 @@ -157,9 +153,13 @@ Lisp_Object Qbytecode; #define Bcurrent_buffer 0160 #define Bset_buffer 0161 #define Bsave_current_buffer_1 0162 /* Replacing Bsave_current_buffer. */ +#if 0 #define Bread_char 0162 /* No longer generated as of v19 */ +#endif +#ifdef BYTE_CODE_SAFE #define Bset_mark 0163 /* this loser is no longer generated as of v18 */ -#define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */ +#endif +#define Binteractive_p 0164 /* Obsolete since Emacs-24.1. */ #define Bforward_char 0165 #define Bforward_word 0166 @@ -184,16 +184,16 @@ Lisp_Object Qbytecode; #define Bdup 0211 #define Bsave_excursion 0212 -#define Bsave_window_excursion 0213 +#define Bsave_window_excursion 0213 /* Obsolete since Emacs-24.1. */ #define Bsave_restriction 0214 #define Bcatch 0215 #define Bunwind_protect 0216 #define Bcondition_case 0217 -#define Btemp_output_buffer_setup 0220 -#define Btemp_output_buffer_show 0221 +#define Btemp_output_buffer_setup 0220 /* Obsolete since Emacs-24.1. */ +#define Btemp_output_buffer_show 0221 /* Obsolete since Emacs-24.1. */ -#define Bunbind_all 0222 +#define Bunbind_all 0222 /* Obsolete. Never used. */ #define Bset_marker 0223 #define Bmatch_beginning 0224 @@ -229,9 +229,15 @@ Lisp_Object Qbytecode; #define BconcatN 0260 #define BinsertN 0261 +/* Bstack_ref is code 0. */ +#define Bstack_set 0262 +#define Bstack_set2 0263 +#define BdiscardN 0266 + #define Bconstant 0300 -#define CONSTANTLIM 0100 +/* 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. */ @@ -244,7 +250,9 @@ struct byte_stack /* 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 @@ -271,6 +279,7 @@ struct byte_stack *byte_stack_list; /* Mark objects on byte_stack_list. Called during GC. */ +#if BYTE_MARK_STACK void mark_byte_stack (void) { @@ -295,7 +304,7 @@ mark_byte_stack (void) mark_object (stack->constants); } } - +#endif /* Unmark objects in the stacks on byte_stack_list. Relocate program counters. Called when GC has completed. */ @@ -349,13 +358,19 @@ 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. */ #define MAYBE_GC() \ + do { \ if (consing_since_gc > gc_cons_threshold \ && consing_since_gc > gc_relative_threshold) \ { \ @@ -363,7 +378,7 @@ unmark_byte_stack (void) Fgarbage_collect (); \ AFTER_POTENTIAL_GC (); \ } \ - else + } while (0) /* Check for jumping out of range. */ @@ -404,6 +419,21 @@ the second, VECTOR, a vector of constants; the third, MAXDEPTH, the maximum stack depth used in this function. If the third argument is incorrect, Emacs may crash. */) (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth) +{ + return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL); +} + +/* 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 + argument list (including &rest, &optional, etc.), and ARGS, of size + NARGS, should be a vector of the actual arguments. The arguments in + ARGS are pushed on the stack according to ARGS_TEMPLATE before + executing BYTESTR. */ + +Lisp_Object +exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, + Lisp_Object args_template, ptrdiff_t nargs, Lisp_Object *args) { int count = SPECPDL_INDEX (); #ifdef BYTE_CODE_METER @@ -414,10 +444,10 @@ If the third argument is incorrect, Emacs may crash. */) /* Lisp_Object v1, v2; */ Lisp_Object *vectorp; #ifdef BYTE_CODE_SAFE - int const_length = XVECTOR (vector)->size; + ptrdiff_t const_length; Lisp_Object *stacke; -#endif int bytestr_length; +#endif struct byte_stack stack; Lisp_Object *top; Lisp_Object result; @@ -434,7 +464,11 @@ If the third argument is incorrect, Emacs may crash. */) CHECK_STRING (bytestr); CHECK_VECTOR (vector); - CHECK_NUMBER (maxdepth); + CHECK_NATNUM (maxdepth); + +#ifdef BYTE_CODE_SAFE + const_length = ASIZE (vector); +#endif if (STRING_MULTIBYTE (bytestr)) /* BYTESTR must have been produced by Emacs 20.2 or the earlier @@ -444,16 +478,23 @@ If the third argument is incorrect, Emacs may crash. */) convert them back to the originally intended unibyte form. */ bytestr = Fstring_as_unibyte (bytestr); +#ifdef BYTE_CODE_SAFE bytestr_length = SBYTES (bytestr); +#endif vectorp = XVECTOR (vector)->contents; stack.byte_string = bytestr; stack.pc = stack.byte_string_start = SDATA (bytestr); stack.constants = vector; - stack.bottom = (Lisp_Object *) alloca (XFASTINT (maxdepth) + if (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (Lisp_Object) < XFASTINT (maxdepth)) + memory_full (SIZE_MAX); + top = (Lisp_Object *) alloca (XFASTINT (maxdepth) * sizeof (Lisp_Object)); - top = stack.bottom - 1; +#if BYTE_MAINTAIN_TOP + stack.bottom = top; stack.top = NULL; +#endif + top -= 1; stack.next = byte_stack_list; byte_stack_list = &stack; @@ -461,6 +502,52 @@ If the third argument is incorrect, Emacs may crash. */) stacke = stack.bottom - 1 + XFASTINT (maxdepth); #endif + if (INTEGERP (args_template)) + { + ptrdiff_t at = XINT (args_template); + int rest = at & 128; + int mandatory = at & 127; + ptrdiff_t nonrest = at >> 8; + eassert (mandatory <= nonrest); + if (nargs <= nonrest) + { + ptrdiff_t i; + for (i = 0 ; i < nargs; i++, args++) + PUSH (*args); + if (nargs < mandatory) + /* Too few arguments. */ + Fsignal (Qwrong_number_of_arguments, + Fcons (Fcons (make_number (mandatory), + rest ? Qand_rest : make_number (nonrest)), + Fcons (make_number (nargs), Qnil))); + else + { + for (; i < nonrest; i++) + PUSH (Qnil); + if (rest) + PUSH (Qnil); + } + } + else if (rest) + { + ptrdiff_t i; + for (i = 0 ; i < nonrest; i++, args++) + PUSH (*args); + PUSH (Flist (nargs - nonrest, args)); + } + else + /* Too many arguments. */ + Fsignal (Qwrong_number_of_arguments, + Fcons (Fcons (make_number (mandatory), + make_number (nonrest)), + Fcons (make_number (nargs), Qnil))); + } + else if (! NILP (args_template)) + /* We should push some arguments on the stack. */ + { + error ("Unknown args template!"); + } + while (1) { #ifdef BYTE_CODE_SAFE @@ -542,7 +629,16 @@ If the third argument is incorrect, Emacs may crash. */) { Lisp_Object v1; v1 = TOP; - TOP = CAR (v1); + if (CONSP (v1)) + TOP = XCAR (v1); + else if (NILP (v1)) + TOP = Qnil; + else + { + BEFORE_POTENTIAL_GC (); + wrong_type_argument (Qlistp, v1); + AFTER_POTENTIAL_GC (); + } break; } @@ -568,7 +664,17 @@ If the third argument is incorrect, Emacs may crash. */) { Lisp_Object v1; v1 = TOP; - TOP = CDR (v1); + if (CONSP (v1)) + TOP = XCDR (v1); + else if (NILP (v1)) + TOP = Qnil; + else + { + BEFORE_POTENTIAL_GC (); + wrong_type_argument (Qlistp, v1); + AFTER_POTENTIAL_GC (); + } + break; break; } @@ -702,7 +808,7 @@ If the third argument is incorrect, Emacs may crash. */) AFTER_POTENTIAL_GC (); break; - case Bunbind_all: + 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 (); @@ -830,37 +936,43 @@ If the third argument is incorrect, Emacs may crash. */) save_excursion_save ()); break; - case Bsave_current_buffer: + case Bsave_current_buffer: /* Obsolete since ??. */ case Bsave_current_buffer_1: record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ()); break; - case Bsave_window_excursion: - BEFORE_POTENTIAL_GC (); - TOP = Fsave_window_excursion (TOP); - AFTER_POTENTIAL_GC (); - break; + case Bsave_window_excursion: /* Obsolete since 24.1. */ + { + register int count1 = SPECPDL_INDEX (); + record_unwind_protect (Fset_window_configuration, + Fcurrent_window_configuration (Qnil)); + BEFORE_POTENTIAL_GC (); + TOP = Fprogn (TOP); + unbind_to (count1, TOP); + AFTER_POTENTIAL_GC (); + break; + } case Bsave_restriction: record_unwind_protect (save_restriction_restore, save_restriction_save ()); break; - case Bcatch: + case Bcatch: /* FIXME: ill-suited for lexbind. */ { Lisp_Object v1; BEFORE_POTENTIAL_GC (); v1 = POP; - TOP = internal_catch (TOP, Feval, v1); + TOP = internal_catch (TOP, eval_sub, v1); AFTER_POTENTIAL_GC (); break; } - case Bunwind_protect: + case Bunwind_protect: /* FIXME: avoid closure for lexbind. */ record_unwind_protect (Fprogn, POP); break; - case Bcondition_case: + case Bcondition_case: /* FIXME: ill-suited for lexbind. */ { Lisp_Object handlers, body; handlers = POP; @@ -871,15 +983,15 @@ If the third argument is incorrect, Emacs may crash. */) break; } - case Btemp_output_buffer_setup: + case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ BEFORE_POTENTIAL_GC (); CHECK_STRING (TOP); - temp_output_buffer_setup (SDATA (TOP)); + temp_output_buffer_setup (SSDATA (TOP)); AFTER_POTENTIAL_GC (); TOP = Vstandard_output; break; - case Btemp_output_buffer_show: + case Btemp_output_buffer_show: /* Obsolete since 24.1. */ { Lisp_Object v1; BEFORE_POTENTIAL_GC (); @@ -899,13 +1011,13 @@ If the third argument is incorrect, Emacs may crash. */) v1 = POP; v2 = TOP; CHECK_NUMBER (v2); - AFTER_POTENTIAL_GC (); op = XINT (v2); immediate_quit = 1; while (--op >= 0 && CONSP (v1)) v1 = XCDR (v1); immediate_quit = 0; TOP = CAR (v1); + AFTER_POTENTIAL_GC (); break; } @@ -1313,7 +1425,7 @@ If the third argument is incorrect, Emacs may crash. */) { Lisp_Object v1; BEFORE_POTENTIAL_GC (); - XSETFASTINT (v1, (int) current_column ()); /* iftc */ + XSETFASTINT (v1, current_column ()); AFTER_POTENTIAL_GC (); PUSH (v1); break; @@ -1351,7 +1463,7 @@ If the third argument is incorrect, Emacs may crash. */) AFTER_POTENTIAL_GC (); break; - case Binteractive_p: + case Binteractive_p: /* Obsolete since 24.1. */ PUSH (Finteractive_p ()); break; @@ -1401,7 +1513,7 @@ If the third argument is incorrect, Emacs may crash. */) CHECK_CHARACTER (TOP); AFTER_POTENTIAL_GC (); c = XFASTINT (TOP); - if (NILP (current_buffer->enable_multibyte_characters)) + if (NILP (BVAR (current_buffer, enable_multibyte_characters))) MAKE_CHAR_MULTIBYTE (c); XSETFASTINT (TOP, syntax_code_spec[(int) SYNTAX (c)]); } @@ -1641,8 +1753,57 @@ If the third argument is incorrect, Emacs may crash. */) #endif case 0: + /* Actually this is Bstack_ref with offset 0, but we use Bdup + for that instead. */ + /* case Bstack_ref: */ abort (); + /* Handy byte-codes for lexical binding. */ + case Bstack_ref+1: + case Bstack_ref+2: + case Bstack_ref+3: + case Bstack_ref+4: + case Bstack_ref+5: + { + Lisp_Object *ptr = top - (op - Bstack_ref); + PUSH (*ptr); + break; + } + case Bstack_ref+6: + { + Lisp_Object *ptr = top - (FETCH); + PUSH (*ptr); + break; + } + case Bstack_ref+7: + { + Lisp_Object *ptr = top - (FETCH2); + PUSH (*ptr); + break; + } + case Bstack_set: + /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ + { + Lisp_Object *ptr = top - (FETCH); + *ptr = POP; + break; + } + case Bstack_set2: + { + Lisp_Object *ptr = top - (FETCH2); + *ptr = POP; + break; + } + case BdiscardN: + op = FETCH; + if (op & 0x80) + { + op &= 0x7F; + top[-op] = TOP; + } + DISCARD (op); + break; + case 255: default: #ifdef BYTE_CODE_SAFE @@ -1679,14 +1840,13 @@ If the third argument is incorrect, Emacs may crash. */) void syms_of_bytecode (void) { - Qbytecode = intern_c_string ("byte-code"); - staticpro (&Qbytecode); + DEFSYM (Qbytecode, "byte-code"); defsubr (&Sbyte_code); #ifdef BYTE_CODE_METER - DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter, + DEFVAR_LISP ("byte-code-meter", Vbyte_code_meter, doc: /* A vector of vectors which holds a histogram of byte-code usage. \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte opcode CODE has been executed. @@ -1694,7 +1854,7 @@ opcode CODE has been executed. indicates how many times the byte opcodes CODE1 and CODE2 have been executed in succession. */); - DEFVAR_BOOL ("byte-metering-on", &byte_metering_on, + DEFVAR_BOOL ("byte-metering-on", byte_metering_on, doc: /* If non-nil, keep profiling information on byte code usage. The variable byte-code-meter indicates how often each byte opcode is used. If a symbol has a property named `byte-code-meter' whose value is an @@ -1702,8 +1862,7 @@ integer, it is incremented each time that symbol's function is called. */); byte_metering_on = 0; Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0)); - Qbyte_code_meter = intern_c_string ("byte-code-meter"); - staticpro (&Qbyte_code_meter); + DEFSYM (Qbyte_code_meter, "byte-code-meter"); { int i = 256; while (i--) @@ -1712,4 +1871,3 @@ integer, it is incremented each time that symbol's function is called. */); } #endif } -