diff options
Diffstat (limited to 'src/bytecode.c')
| -rw-r--r-- | src/bytecode.c | 673 |
1 files changed, 493 insertions, 180 deletions
diff --git a/src/bytecode.c b/src/bytecode.c index 472992be180..8704e6069dd 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -21,11 +21,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" #include "blockinput.h" +#include "sysstdio.h" #include "character.h" #include "buffer.h" #include "keyboard.h" #include "syntax.h" #include "window.h" +#include "puresize.h" /* Work around GCC bug 54561. */ #if GNUC_PREREQ (4, 3, 0) @@ -185,6 +187,7 @@ DEFINE (Bfollowing_char, 0147) \ DEFINE (Bpreceding_char, 0150) \ DEFINE (Bcurrent_column, 0151) \ DEFINE (Bindent_to, 0152) \ +/* 0153 was Bscan_buffer in v17. */ \ DEFINE (Beolp, 0154) \ DEFINE (Beobp, 0155) \ DEFINE (Bbolp, 0156) \ @@ -192,6 +195,7 @@ DEFINE (Bbobp, 0157) \ DEFINE (Bcurrent_buffer, 0160) \ DEFINE (Bset_buffer, 0161) \ DEFINE (Bsave_current_buffer_1, 0162) /* Replacing Bsave_current_buffer. */ \ +/* 0163 was Bset_mark in v17. */ \ DEFINE (Binteractive_p, 0164) /* Obsolete since Emacs-24.1. */ \ \ DEFINE (Bforward_char, 0165) \ @@ -226,7 +230,7 @@ DEFINE (Bcondition_case, 0217) /* Obsolete since Emacs-25. */ \ 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) /* Obsolete. Never used. */ \ +/* 0222 was Bunbind_all, never used. */ \ \ DEFINE (Bset_marker, 0223) \ DEFINE (Bmatch_beginning, 0224) \ @@ -252,11 +256,7 @@ DEFINE (Brem, 0246) \ DEFINE (Bnumberp, 0247) \ DEFINE (Bintegerp, 0250) \ \ -DEFINE (BRgoto, 0252) \ -DEFINE (BRgotoifnil, 0253) \ -DEFINE (BRgotoifnonnil, 0254) \ -DEFINE (BRgotoifnilelsepop, 0255) \ -DEFINE (BRgotoifnonnilelsepop, 0256) \ +/* 0252-0256 were relative jumps, apparently never used. */ \ \ DEFINE (BlistN, 0257) \ DEFINE (BconcatN, 0260) \ @@ -276,11 +276,6 @@ enum byte_code_op #define DEFINE(name, value) name = value, BYTE_CODES #undef DEFINE - -#if BYTE_CODE_SAFE - Bscan_buffer = 0153, /* No longer generated as of v18. */ - Bset_mark = 0163, /* this loser is no longer generated as of v18 */ -#endif }; /* Fetch the next byte from the bytecode stream. */ @@ -290,7 +285,7 @@ enum byte_code_op /* Fetch two bytes from the bytecode stream and make a 16-bit number out of them. */ -#define FETCH2 (op = FETCH, op + (FETCH << 8)) +#define FETCH2 (op = FETCH, op | (FETCH << 8)) /* Push X onto the execution stack. The expression X should not contain TOP, to avoid competing side effects. */ @@ -330,8 +325,8 @@ If the third argument is incorrect, Emacs may crash. */) the original unibyte form. */ bytestr = Fstring_as_unibyte (bytestr); } - - return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL); + Lisp_Object args[] = {0, bytestr, vector, maxdepth}; + return exec_byte_code (Fmake_byte_code (4, args), 0, 0, NULL); } static void @@ -340,70 +335,249 @@ 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 - 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. */ +/* Layout of the stack frame header. */ +enum stack_frame_index { + SFI_SAVED_FP, /* previous frame pointer */ + + /* In a frame called directly from C, the following two members are NULL. */ + SFI_SAVED_TOP, /* previous stack pointer */ + SFI_SAVED_PC, /* previous program counter */ + + SFI_FUN, /* current function object */ + + SF_SIZE /* number of words in the header */ +}; + +/* The bytecode stack size in Lisp words. + This is a fairly generous amount, but: + - if users need more, we could allocate more, or just reserve the address + space and allocate on demand + - if threads are used more, then it might be a good idea to reduce the + per-thread overhead in time and space + - for maximum flexibility but a small runtime penalty, we could allocate + the stack in smaller chunks as needed +*/ +#define BC_STACK_SIZE (512 * 1024) + +/* Bytecode interpreter stack: + + |--------------| -- + |fun | | ^ stack growth + |saved_pc | | | direction + |saved_top ------- | + fp--->|saved_fp ---- | | current frame + |--------------| | | | (called from bytecode in this example) + | (free) | | | | + top-->| ...stack... | | | | + : ... : | | | + |incoming args | | | | + |--------------| | | -- + |fun | | | | + |saved_pc | | | | + |saved_top | | | | + |saved_fp |<- | | previous frame + |--------------| | | + | (free) | | | + | ...stack... |<---- | + : ... : | + |incoming args | | + |--------------| -- + : : +*/ + +INLINE void * +sf_get_ptr (Lisp_Object *fp, enum stack_frame_index index) +{ + return XLP (fp[index]); +} + +INLINE void +sf_set_ptr (Lisp_Object *fp, enum stack_frame_index index, void *value) +{ + fp[index] = XIL ((uintptr_t)value); +} + +INLINE Lisp_Object * +sf_get_lisp_ptr (Lisp_Object *fp, enum stack_frame_index index) +{ + return sf_get_ptr (fp, index); +} + +INLINE void +sf_set_lisp_ptr (Lisp_Object *fp, enum stack_frame_index index, + Lisp_Object *value) +{ + sf_set_ptr (fp, index, value); +} + +INLINE const unsigned char * +sf_get_saved_pc (Lisp_Object *fp) +{ + return sf_get_ptr (fp, SFI_SAVED_PC); +} + +INLINE void +sf_set_saved_pc (Lisp_Object *fp, const unsigned char *value) +{ + sf_set_ptr (fp, SFI_SAVED_PC, (unsigned char *)value); +} + +void +init_bc_thread (struct bc_thread_state *bc) +{ + bc->stack = xmalloc (BC_STACK_SIZE * sizeof *bc->stack); + bc->stack_end = bc->stack + BC_STACK_SIZE; + /* Put a dummy header at the bottom to indicate the first free location. */ + bc->fp = bc->stack; + memset (bc->fp, 0, SF_SIZE * sizeof *bc->stack); +} + +void +free_bc_thread (struct bc_thread_state *bc) +{ + xfree (bc->stack); +} + +void +mark_bytecode (struct bc_thread_state *bc) +{ + Lisp_Object *fp = bc->fp; + Lisp_Object *top = NULL; /* stack pointer of topmost frame not known */ + for (;;) + { + Lisp_Object *next_fp = sf_get_lisp_ptr (fp, SFI_SAVED_FP); + /* Only the dummy frame at the bottom has saved_fp = NULL. */ + if (!next_fp) + break; + mark_object (fp[SFI_FUN]); + Lisp_Object *frame_base = next_fp + SF_SIZE; + if (top) + { + /* The stack pointer of a frame is known: mark the part of the stack + above it conservatively. This includes any outgoing arguments. */ + mark_memory (top + 1, fp); + /* Mark the rest of the stack precisely. */ + mark_objects (frame_base, top + 1 - frame_base); + } + else + { + /* The stack pointer is unknown -- mark everything conservatively. */ + mark_memory (frame_base, fp); + } + top = sf_get_lisp_ptr (fp, SFI_SAVED_TOP); + fp = next_fp; + } +} + +DEFUN ("internal-stack-stats", Finternal_stack_stats, Sinternal_stack_stats, + 0, 0, 0, + doc: /* internal */) + (void) +{ + struct bc_thread_state *bc = ¤t_thread->bc; + int nframes = 0; + int nruns = 0; + for (Lisp_Object *fp = bc->fp; fp; fp = sf_get_lisp_ptr (fp, SFI_SAVED_FP)) + { + nframes++; + if (sf_get_lisp_ptr (fp, SFI_SAVED_TOP) == NULL) + nruns++; + } + fprintf (stderr, "%d stack frames, %d runs\n", nframes, nruns); + return Qnil; +} + +/* Whether a stack pointer is valid in the current frame. */ +INLINE bool +valid_sp (struct bc_thread_state *bc, Lisp_Object *sp) +{ + Lisp_Object *fp = bc->fp; + return sp < fp && sp + 1 >= sf_get_lisp_ptr (fp, SFI_SAVED_FP) + SF_SIZE; +} + +/* Execute the byte-code in FUN. ARGS_TEMPLATE is the function arity + encoded as an integer (the one in FUN is ignored), 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 FUN. */ Lisp_Object -exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, - Lisp_Object args_template, ptrdiff_t nargs, Lisp_Object *args) +exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, + ptrdiff_t nargs, Lisp_Object *args) { #ifdef BYTE_CODE_METER int volatile this_op = 0; #endif + unsigned char quitcounter = 1; + struct bc_thread_state *bc = ¤t_thread->bc; - eassert (!STRING_MULTIBYTE (bytestr)); + /* Values used for the first stack record when called from C. */ + Lisp_Object *top = NULL; + unsigned char const *pc = NULL; + Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); + + setup_frame: ; + eassert (!STRING_MULTIBYTE (bytestr)); + eassert (string_immovable_p (bytestr)); + /* FIXME: in debug mode (!NDEBUG, BYTE_CODE_SAFE or enabled checking), + save the specpdl index on function entry and check that it is the same + when returning, to detect unwind imbalances. This would require adding + a field to the frame header. */ + + Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); + Lisp_Object maxdepth = AREF (fun, COMPILED_STACK_DEPTH); ptrdiff_t const_length = ASIZE (vector); ptrdiff_t bytestr_length = SCHARS (bytestr); Lisp_Object *vectorp = XVECTOR (vector)->contents; - unsigned char quitcounter = 1; - EMACS_INT stack_items = XFIXNAT (maxdepth) + 1; - USE_SAFE_ALLOCA; - void *alloc; - SAFE_ALLOCA_LISP_EXTRA (alloc, stack_items, bytestr_length); - Lisp_Object *stack_base = alloc; - Lisp_Object *top = stack_base; - *top = vector; /* Ensure VECTOR survives GC (Bug#33014). */ - Lisp_Object *stack_lim = stack_base + stack_items; - unsigned char const *bytestr_data = memcpy (stack_lim, - SDATA (bytestr), bytestr_length); - unsigned char const *pc = bytestr_data; - ptrdiff_t count = SPECPDL_INDEX (); - - if (!NILP (args_template)) - { - eassert (FIXNUMP (args_template)); - ptrdiff_t at = XFIXNUM (args_template); - bool rest = (at & 128) != 0; - int mandatory = at & 127; - ptrdiff_t nonrest = at >> 8; - ptrdiff_t maxargs = rest ? PTRDIFF_MAX : nonrest; - if (! (mandatory <= nargs && nargs <= maxargs)) - Fsignal (Qwrong_number_of_arguments, - list2 (Fcons (make_fixnum (mandatory), make_fixnum (nonrest)), - make_fixnum (nargs))); - ptrdiff_t pushedargs = min (nonrest, nargs); - for (ptrdiff_t i = 0; i < pushedargs; i++, args++) - PUSH (*args); - if (nonrest < nargs) - PUSH (Flist (nargs - nonrest, args)); - else - for (ptrdiff_t i = nargs - rest; i < nonrest; i++) - PUSH (Qnil); - } + EMACS_INT max_stack = XFIXNAT (maxdepth); + Lisp_Object *frame_base = bc->fp + SF_SIZE; + Lisp_Object *fp = frame_base + max_stack; + + if (fp + SF_SIZE > bc->stack_end) + error ("Bytecode stack overflow"); + + /* Save the function object so that the bytecode and vector are + held from removal by the GC. */ + fp[SFI_FUN] = fun; + /* Save previous stack pointer and pc in the new frame. If we came + directly from outside, these will be NULL. */ + sf_set_lisp_ptr (fp, SFI_SAVED_TOP, top); + sf_set_saved_pc (fp, pc); + sf_set_lisp_ptr (fp, SFI_SAVED_FP, bc->fp); + bc->fp = fp; + + top = frame_base - 1; + unsigned char const *bytestr_data = SDATA (bytestr); + pc = bytestr_data; + + /* ARGS_TEMPLATE is composed of bit fields: + bits 0..6 minimum number of arguments + bits 7 1 iff &rest argument present + bits 8..14 maximum number of arguments */ + bool rest = (args_template & 128) != 0; + int mandatory = args_template & 127; + ptrdiff_t nonrest = args_template >> 8; + if (! (mandatory <= nargs && (rest || nargs <= nonrest))) + Fsignal (Qwrong_number_of_arguments, + list2 (Fcons (make_fixnum (mandatory), make_fixnum (nonrest)), + make_fixnum (nargs))); + ptrdiff_t pushedargs = min (nonrest, nargs); + for (ptrdiff_t i = 0; i < pushedargs; i++, args++) + PUSH (*args); + if (nonrest < nargs) + PUSH (Flist (nargs - nonrest, args)); + else + for (ptrdiff_t i = nargs - rest; i < nonrest; i++) + PUSH (Qnil); while (true) { int op; enum handlertype type; - if (BYTE_CODE_SAFE && ! (stack_base <= top && top < stack_lim)) + if (BYTE_CODE_SAFE && !valid_sp (bc, top)) emacs_abort (); #ifdef BYTE_CODE_METER @@ -451,17 +625,13 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, #ifdef BYTE_CODE_THREADED - /* A convenience define that saves us a lot of typing and makes - the table clearer. */ -#define LABEL(OP) [OP] = &&insn_ ## OP - /* This is the dispatch table for the threaded interpreter. */ static const void *const targets[256] = { [0 ... (Bconstant - 1)] = &&insn_default, [Bconstant ... 255] = &&insn_Bconstant, -#define DEFINE(name, value) LABEL (name) , +#define DEFINE(name, value) [name] = &&insn_ ## name, BYTE_CODES #undef DEFINE }; @@ -629,7 +799,59 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, } } #endif - TOP = Ffuncall (op + 1, &TOP); + 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'"); + } + + ptrdiff_t call_nargs = op; + Lisp_Object call_fun = TOP; + Lisp_Object *call_args = &TOP + 1; + + specpdl_ref count1 = record_in_backtrace (call_fun, + call_args, call_nargs); + maybe_gc (); + if (debug_on_next_call) + do_debug_on_call (Qlambda, count1); + + Lisp_Object original_fun = call_fun; + if (SYMBOLP (call_fun)) + call_fun = XSYMBOL (call_fun)->u.s.function; + Lisp_Object template; + Lisp_Object bytecode; + if (COMPILEDP (call_fun) + // Lexical binding only. + && (template = AREF (call_fun, COMPILED_ARGLIST), + FIXNUMP (template)) + // No autoloads. + && (bytecode = AREF (call_fun, COMPILED_BYTECODE), + !CONSP (bytecode))) + { + fun = call_fun; + bytestr = bytecode; + args_template = XFIXNUM (template); + nargs = call_nargs; + args = call_args; + goto setup_frame; + } + + Lisp_Object val; + if (SUBRP (call_fun) && !SUBR_NATIVE_COMPILED_DYNP (call_fun)) + val = funcall_subr (XSUBR (call_fun), call_nargs, call_args); + else + val = funcall_general (original_fun, call_nargs, call_args); + + lisp_eval_depth--; + if (backtrace_debug_on_exit (specpdl_ptr - 1)) + val = call_debugger (list2 (Qexit, val)); + specpdl_ptr--; + + TOP = val; NEXT; } @@ -649,20 +871,13 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bunbind5): op -= Bunbind; dounbind: - unbind_to (SPECPDL_INDEX () - op, Qnil); - 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. */ - unbind_to (count, Qnil); + unbind_to (specpdl_ref_add (SPECPDL_INDEX (), -op), Qnil); NEXT; CASE (Bgoto): op = FETCH2; op_branch: op -= pc - bytestr_data; - op_relative_branch: if (BYTE_CODE_SAFE && ! (bytestr_data - pc <= op && op < bytestr_data + bytestr_length - pc)) @@ -697,38 +912,41 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, DISCARD (1); NEXT; - CASE (BRgoto): - op = FETCH - 128; - goto op_relative_branch; - - CASE (BRgotoifnil): - op = FETCH - 128; - if (NILP (POP)) - goto op_relative_branch; - NEXT; - - CASE (BRgotoifnonnil): - op = FETCH - 128; - if (!NILP (POP)) - goto op_relative_branch; - NEXT; - - CASE (BRgotoifnilelsepop): - op = FETCH - 128; - if (NILP (TOP)) - goto op_relative_branch; - DISCARD (1); - NEXT; - - CASE (BRgotoifnonnilelsepop): - op = FETCH - 128; - if (!NILP (TOP)) - goto op_relative_branch; - DISCARD (1); - NEXT; - CASE (Breturn): - goto exit; + { + Lisp_Object *saved_top = sf_get_lisp_ptr (bc->fp, SFI_SAVED_TOP); + if (saved_top) + { + Lisp_Object val = TOP; + + lisp_eval_depth--; + if (backtrace_debug_on_exit (specpdl_ptr - 1)) + val = call_debugger (list2 (Qexit, val)); + specpdl_ptr--; + + top = saved_top; + pc = sf_get_saved_pc (bc->fp); + Lisp_Object *fp = sf_get_lisp_ptr (bc->fp, SFI_SAVED_FP); + bc->fp = fp; + + Lisp_Object fun = fp[SFI_FUN]; + Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); + Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); + bytestr_data = SDATA (bytestr); + vectorp = XVECTOR (vector)->contents; + if (BYTE_CODE_SAFE) + { + /* Only required for checking, not for execution. */ + const_length = ASIZE (vector); + bytestr_length = SCHARS (bytestr); + } + + TOP = val; + NEXT; + } + else + goto exit; + } CASE (Bdiscard): DISCARD (1); @@ -749,7 +967,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bsave_window_excursion): /* Obsolete since 24.1. */ { - ptrdiff_t count1 = SPECPDL_INDEX (); + specpdl_ref count1 = SPECPDL_INDEX (); record_unwind_protect (restore_window_configuration, Fcurrent_window_configuration (Qnil)); TOP = Fprogn (TOP); @@ -783,9 +1001,23 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, if (sys_setjmp (c->jmp)) { struct handler *c = handlerlist; + handlerlist = c->next; top = c->bytecode_top; op = c->bytecode_dest; - handlerlist = c->next; + Lisp_Object *fp = bc->fp; + + Lisp_Object fun = fp[SFI_FUN]; + Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); + Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); + bytestr_data = SDATA (bytestr); + vectorp = XVECTOR (vector)->contents; + if (BYTE_CODE_SAFE) + { + /* Only required for checking, not for execution. */ + const_length = ASIZE (vector); + bytestr_length = SCHARS (bytestr); + } + pc = bytestr_data; PUSH (c->val); goto op_branch; } @@ -825,7 +1057,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); + unbind_to (specpdl_ref_add (SPECPDL_INDEX (), -1), Qnil); NEXT; } @@ -903,15 +1135,39 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Baref): { - Lisp_Object v1 = POP; - TOP = Faref (TOP, v1); + Lisp_Object idxval = POP; + Lisp_Object arrayval = TOP; + ptrdiff_t size; + ptrdiff_t idx; + if (((VECTORP (arrayval) && (size = ASIZE (arrayval), true)) + || (RECORDP (arrayval) && (size = PVSIZE (arrayval), true))) + && FIXNUMP (idxval) + && (idx = XFIXNUM (idxval), + idx >= 0 && idx < size)) + TOP = AREF (arrayval, idx); + else + TOP = Faref (arrayval, idxval); NEXT; } CASE (Baset): { - Lisp_Object v2 = POP, v1 = POP; - TOP = Faset (TOP, v1, v2); + Lisp_Object newelt = POP; + Lisp_Object idxval = POP; + Lisp_Object arrayval = TOP; + ptrdiff_t size; + ptrdiff_t idx; + if (((VECTORP (arrayval) && (size = ASIZE (arrayval), true)) + || (RECORDP (arrayval) && (size = PVSIZE (arrayval), true))) + && FIXNUMP (idxval) + && (idx = XFIXNUM (idxval), + idx >= 0 && idx < size)) + { + ASET (arrayval, idx, newelt); + TOP = newelt; + } + else + TOP = Faset (arrayval, idxval, newelt); NEXT; } @@ -986,43 +1242,72 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Beqlsign): { - Lisp_Object v1 = POP; - TOP = arithcompare (TOP, v1, ARITH_EQUAL); + Lisp_Object v2 = POP; + Lisp_Object v1 = TOP; + if (FIXNUMP (v1) && FIXNUMP (v2)) + TOP = BASE_EQ(v1, v2) ? Qt : Qnil; + else + TOP = arithcompare (v1, v2, ARITH_EQUAL); NEXT; } CASE (Bgtr): { - Lisp_Object v1 = POP; - TOP = arithcompare (TOP, v1, ARITH_GRTR); + Lisp_Object v2 = POP; + Lisp_Object v1 = TOP; + if (FIXNUMP (v1) && FIXNUMP (v2)) + TOP = XFIXNUM (v1) > XFIXNUM (v2) ? Qt : Qnil; + else + TOP = arithcompare (v1, v2, ARITH_GRTR); NEXT; } CASE (Blss): { - Lisp_Object v1 = POP; - TOP = arithcompare (TOP, v1, ARITH_LESS); + Lisp_Object v2 = POP; + Lisp_Object v1 = TOP; + if (FIXNUMP (v1) && FIXNUMP (v2)) + TOP = XFIXNUM (v1) < XFIXNUM (v2) ? Qt : Qnil; + else + TOP = arithcompare (v1, v2, ARITH_LESS); NEXT; } CASE (Bleq): { - Lisp_Object v1 = POP; - TOP = arithcompare (TOP, v1, ARITH_LESS_OR_EQUAL); + Lisp_Object v2 = POP; + Lisp_Object v1 = TOP; + if (FIXNUMP (v1) && FIXNUMP (v2)) + TOP = XFIXNUM (v1) <= XFIXNUM (v2) ? Qt : Qnil; + else + TOP = arithcompare (v1, v2, ARITH_LESS_OR_EQUAL); NEXT; } CASE (Bgeq): { - Lisp_Object v1 = POP; - TOP = arithcompare (TOP, v1, ARITH_GRTR_OR_EQUAL); + Lisp_Object v2 = POP; + Lisp_Object v1 = TOP; + if (FIXNUMP (v1) && FIXNUMP (v2)) + TOP = XFIXNUM (v1) >= XFIXNUM (v2) ? Qt : Qnil; + else + TOP = arithcompare (v1, v2, ARITH_GRTR_OR_EQUAL); NEXT; } CASE (Bdiff): - DISCARD (1); - TOP = Fminus (2, &TOP); - NEXT; + { + Lisp_Object v2 = POP; + Lisp_Object v1 = TOP; + EMACS_INT res; + if (FIXNUMP (v1) && FIXNUMP (v2) + && (res = XFIXNUM (v1) - XFIXNUM (v2), + !FIXNUM_OVERFLOW_P (res))) + TOP = make_fixnum (res); + else + TOP = Fminus (2, &TOP); + NEXT; + } CASE (Bnegate): TOP = (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM @@ -1031,34 +1316,83 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; CASE (Bplus): - DISCARD (1); - TOP = Fplus (2, &TOP); - NEXT; + { + Lisp_Object v2 = POP; + Lisp_Object v1 = TOP; + EMACS_INT res; + if (FIXNUMP (v1) && FIXNUMP (v2) + && (res = XFIXNUM (v1) + XFIXNUM (v2), + !FIXNUM_OVERFLOW_P (res))) + TOP = make_fixnum (res); + else + TOP = Fplus (2, &TOP); + NEXT; + } CASE (Bmax): - DISCARD (1); - TOP = Fmax (2, &TOP); - NEXT; + { + Lisp_Object v2 = POP; + Lisp_Object v1 = TOP; + if (FIXNUMP (v1) && FIXNUMP (v2)) + { + if (XFIXNUM (v2) > XFIXNUM (v1)) + TOP = v2; + } + else + TOP = Fmax (2, &TOP); + NEXT; + } CASE (Bmin): - DISCARD (1); - TOP = Fmin (2, &TOP); - NEXT; + { + Lisp_Object v2 = POP; + Lisp_Object v1 = TOP; + if (FIXNUMP (v1) && FIXNUMP (v2)) + { + if (XFIXNUM (v2) < XFIXNUM (v1)) + TOP = v2; + } + else + TOP = Fmin (2, &TOP); + NEXT; + } CASE (Bmult): - DISCARD (1); - TOP = Ftimes (2, &TOP); - NEXT; + { + Lisp_Object v2 = POP; + Lisp_Object v1 = TOP; + intmax_t res; + if (FIXNUMP (v1) && FIXNUMP (v2) + && !INT_MULTIPLY_WRAPV (XFIXNUM (v1), XFIXNUM (v2), &res) + && !FIXNUM_OVERFLOW_P (res)) + TOP = make_fixnum (res); + else + TOP = Ftimes (2, &TOP); + NEXT; + } CASE (Bquo): - DISCARD (1); - TOP = Fquo (2, &TOP); - NEXT; + { + Lisp_Object v2 = POP; + Lisp_Object v1 = TOP; + EMACS_INT res; + if (FIXNUMP (v1) && FIXNUMP (v2) && XFIXNUM (v2) != 0 + && (res = XFIXNUM (v1) / XFIXNUM (v2), + !FIXNUM_OVERFLOW_P (res))) + TOP = make_fixnum (res); + else + TOP = Fquo (2, &TOP); + NEXT; + } CASE (Brem): { - Lisp_Object v1 = POP; - TOP = Frem (TOP, v1); + Lisp_Object v2 = POP; + Lisp_Object v1 = TOP; + if (FIXNUMP (v1) && FIXNUMP (v2) && XFIXNUM (v2) != 0) + TOP = make_fixnum (XFIXNUM (v1) % XFIXNUM (v2)); + else + TOP = Frem (v1, v2); NEXT; } @@ -1081,12 +1415,8 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; CASE (Bpoint_max): - { - Lisp_Object v1; - XSETFASTINT (v1, ZV); - PUSH (v1); - NEXT; - } + PUSH (make_fixed_natnum (ZV)); + NEXT; CASE (Bpoint_min): PUSH (make_fixed_natnum (BEGV)); @@ -1167,13 +1497,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; CASE (Bchar_syntax): - { - CHECK_CHARACTER (TOP); - int c = XFIXNAT (TOP); - if (NILP (BVAR (current_buffer, enable_multibyte_characters))) - c = make_char_multibyte (c); - XSETFASTINT (TOP, syntax_code_spec[SYNTAX (c)]); - } + TOP = Fchar_syntax (TOP); NEXT; CASE (Bbuffer_substring): @@ -1291,15 +1615,23 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bsetcar): { - Lisp_Object v1 = POP; - TOP = Fsetcar (TOP, v1); + Lisp_Object newval = POP; + Lisp_Object cell = TOP; + CHECK_CONS (cell); + CHECK_IMPURE (cell, XCONS (cell)); + XSETCAR (cell, newval); + TOP = newval; NEXT; } CASE (Bsetcdr): { - Lisp_Object v1 = POP; - TOP = Fsetcdr (TOP, v1); + Lisp_Object newval = POP; + Lisp_Object cell = TOP; + CHECK_CONS (cell); + CHECK_IMPURE (cell, XCONS (cell)); + XSETCDR (cell, newval); + TOP = newval; NEXT; } @@ -1324,19 +1656,6 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, TOP = INTEGERP (TOP) ? Qt : Qnil; NEXT; -#if BYTE_CODE_SAFE - /* These are intentionally written using 'case' syntax, - because they are incompatible with the threaded - interpreter. */ - - case Bset_mark: - error ("set-mark is an obsolete bytecode"); - break; - case Bscan_buffer: - error ("scan-buffer is an obsolete bytecode"); - break; -#endif - CASE_ABORT: /* Actually this is Bstack_ref with offset 0, but we use Bdup for that instead. */ @@ -1437,16 +1756,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, exit: - /* Binds and unbinds are supposed to be compiled balanced. */ - if (SPECPDL_INDEX () != count) - { - if (SPECPDL_INDEX () > count) - unbind_to (count, Qnil); - error ("binding stack not balanced (serious byte compiler bug)"); - } + bc->fp = sf_get_lisp_ptr (bc->fp, SFI_SAVED_FP); Lisp_Object result = TOP; - SAFE_FREE (); return result; } @@ -1468,6 +1780,7 @@ void syms_of_bytecode (void) { defsubr (&Sbyte_code); + defsubr (&Sinternal_stack_stats); #ifdef BYTE_CODE_METER |