?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
; * etc/NEWS (Changes in Frame- and Window- Handling): Demote section.
[emacs.git] / src / bytecode.c
blob464adc633a896e64fc795cd32b93595101f2f480
1 /* Execution of byte code produced by bytecomp.el.
2 Copyright (C) 1985-1988, 1993, 2000-2015 Free Software Foundation,
3 Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
19
20 /*
21 hacked on by jwz@lucid.com 17-jun-91
22 o added a compile-time switch to turn on simple sanity checking;
23 o put back the obsolete byte-codes for error-detection;
24 o added a new instruction, unbind_all, which I will use for
25 tail-recursion elimination;
26 o made temp_output_buffer_show be called with the right number
27 of args;
28 o made the new bytecodes be called with args in the right order;
29 o added metering support.
30
31 by Hallvard:
32 o added relative jump instructions;
33 o all conditionals now only do QUIT if they jump.
34 */
35
36 #include <config.h>
37
38 #include "lisp.h"
39 #include "blockinput.h"
40 #include "character.h"
41 #include "buffer.h"
42 #include "keyboard.h"
43 #include "syntax.h"
44 #include "window.h"
45
46 #ifdef CHECK_FRAME_FONT
47 #include "frame.h"
48 #include "xterm.h"
49 #endif
50
51 /*
52 * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for
53 * debugging the byte compiler...)
54 *
55 * define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
56 */
57 /* #define BYTE_CODE_SAFE */
58 /* #define BYTE_CODE_METER */
59
60 /* If BYTE_CODE_THREADED is defined, then the interpreter will be
61 indirect threaded, using GCC's computed goto extension. This code,
62 as currently implemented, is incompatible with BYTE_CODE_SAFE and
63 BYTE_CODE_METER. */
64 #if (defined __GNUC__ && !defined __STRICT_ANSI__ \
65 && !defined BYTE_CODE_SAFE && !defined BYTE_CODE_METER)
66 #define BYTE_CODE_THREADED
67 #endif
68
69 \f
70 #ifdef BYTE_CODE_METER
71
72 #define METER_2(code1, code2) AREF (AREF (Vbyte_code_meter, code1), code2)
73 #define METER_1(code) METER_2 (0, code)
74
75 #define METER_CODE(last_code, this_code) \
76 { \
77 if (byte_metering_on) \
78 { \
79 if (XFASTINT (METER_1 (this_code)) < MOST_POSITIVE_FIXNUM) \
80 XSETFASTINT (METER_1 (this_code), \
81 XFASTINT (METER_1 (this_code)) + 1); \
82 if (last_code \
83 && (XFASTINT (METER_2 (last_code, this_code)) \
84 < MOST_POSITIVE_FIXNUM)) \
85 XSETFASTINT (METER_2 (last_code, this_code), \
86 XFASTINT (METER_2 (last_code, this_code)) + 1); \
87 } \
88 }
89
90 #endif /* BYTE_CODE_METER */
91 \f
92
93 /* Byte codes: */
94
95 #define BYTE_CODES \
96 DEFINE (Bstack_ref, 0) /* Actually, Bstack_ref+0 is not implemented: use dup. */ \
97 DEFINE (Bstack_ref1, 1) \
98 DEFINE (Bstack_ref2, 2) \
99 DEFINE (Bstack_ref3, 3) \
100 DEFINE (Bstack_ref4, 4) \
101 DEFINE (Bstack_ref5, 5) \
102 DEFINE (Bstack_ref6, 6) \
103 DEFINE (Bstack_ref7, 7) \
104 DEFINE (Bvarref, 010) \
105 DEFINE (Bvarref1, 011) \
106 DEFINE (Bvarref2, 012) \
107 DEFINE (Bvarref3, 013) \
108 DEFINE (Bvarref4, 014) \
109 DEFINE (Bvarref5, 015) \
110 DEFINE (Bvarref6, 016) \
111 DEFINE (Bvarref7, 017) \
112 DEFINE (Bvarset, 020) \
113 DEFINE (Bvarset1, 021) \
114 DEFINE (Bvarset2, 022) \
115 DEFINE (Bvarset3, 023) \
116 DEFINE (Bvarset4, 024) \
117 DEFINE (Bvarset5, 025) \
118 DEFINE (Bvarset6, 026) \
119 DEFINE (Bvarset7, 027) \
120 DEFINE (Bvarbind, 030) \
121 DEFINE (Bvarbind1, 031) \
122 DEFINE (Bvarbind2, 032) \
123 DEFINE (Bvarbind3, 033) \
124 DEFINE (Bvarbind4, 034) \
125 DEFINE (Bvarbind5, 035) \
126 DEFINE (Bvarbind6, 036) \
127 DEFINE (Bvarbind7, 037) \
128 DEFINE (Bcall, 040) \
129 DEFINE (Bcall1, 041) \
130 DEFINE (Bcall2, 042) \
131 DEFINE (Bcall3, 043) \
132 DEFINE (Bcall4, 044) \
133 DEFINE (Bcall5, 045) \
134 DEFINE (Bcall6, 046) \
135 DEFINE (Bcall7, 047) \
136 DEFINE (Bunbind, 050) \
137 DEFINE (Bunbind1, 051) \
138 DEFINE (Bunbind2, 052) \
139 DEFINE (Bunbind3, 053) \
140 DEFINE (Bunbind4, 054) \
141 DEFINE (Bunbind5, 055) \
142 DEFINE (Bunbind6, 056) \
143 DEFINE (Bunbind7, 057) \
144 \
145 DEFINE (Bpophandler, 060) \
146 DEFINE (Bpushconditioncase, 061) \
147 DEFINE (Bpushcatch, 062) \
148 \
149 DEFINE (Bnth, 070) \
150 DEFINE (Bsymbolp, 071) \
151 DEFINE (Bconsp, 072) \
152 DEFINE (Bstringp, 073) \
153 DEFINE (Blistp, 074) \
154 DEFINE (Beq, 075) \
155 DEFINE (Bmemq, 076) \
156 DEFINE (Bnot, 077) \
157 DEFINE (Bcar, 0100) \
158 DEFINE (Bcdr, 0101) \
159 DEFINE (Bcons, 0102) \
160 DEFINE (Blist1, 0103) \
161 DEFINE (Blist2, 0104) \
162 DEFINE (Blist3, 0105) \
163 DEFINE (Blist4, 0106) \
164 DEFINE (Blength, 0107) \
165 DEFINE (Baref, 0110) \
166 DEFINE (Baset, 0111) \
167 DEFINE (Bsymbol_value, 0112) \
168 DEFINE (Bsymbol_function, 0113) \
169 DEFINE (Bset, 0114) \
170 DEFINE (Bfset, 0115) \
171 DEFINE (Bget, 0116) \
172 DEFINE (Bsubstring, 0117) \
173 DEFINE (Bconcat2, 0120) \
174 DEFINE (Bconcat3, 0121) \
175 DEFINE (Bconcat4, 0122) \
176 DEFINE (Bsub1, 0123) \
177 DEFINE (Badd1, 0124) \
178 DEFINE (Beqlsign, 0125) \
179 DEFINE (Bgtr, 0126) \
180 DEFINE (Blss, 0127) \
181 DEFINE (Bleq, 0130) \
182 DEFINE (Bgeq, 0131) \
183 DEFINE (Bdiff, 0132) \
184 DEFINE (Bnegate, 0133) \
185 DEFINE (Bplus, 0134) \
186 DEFINE (Bmax, 0135) \
187 DEFINE (Bmin, 0136) \
188 DEFINE (Bmult, 0137) \
189 \
190 DEFINE (Bpoint, 0140) \
191 /* Was Bmark in v17. */ \
192 DEFINE (Bsave_current_buffer, 0141) /* Obsolete. */ \
193 DEFINE (Bgoto_char, 0142) \
194 DEFINE (Binsert, 0143) \
195 DEFINE (Bpoint_max, 0144) \
196 DEFINE (Bpoint_min, 0145) \
197 DEFINE (Bchar_after, 0146) \
198 DEFINE (Bfollowing_char, 0147) \
199 DEFINE (Bpreceding_char, 0150) \
200 DEFINE (Bcurrent_column, 0151) \
201 DEFINE (Bindent_to, 0152) \
202 DEFINE (Beolp, 0154) \
203 DEFINE (Beobp, 0155) \
204 DEFINE (Bbolp, 0156) \
205 DEFINE (Bbobp, 0157) \
206 DEFINE (Bcurrent_buffer, 0160) \
207 DEFINE (Bset_buffer, 0161) \
208 DEFINE (Bsave_current_buffer_1, 0162) /* Replacing Bsave_current_buffer. */ \
209 DEFINE (Binteractive_p, 0164) /* Obsolete since Emacs-24.1. */ \
210 \
211 DEFINE (Bforward_char, 0165) \
212 DEFINE (Bforward_word, 0166) \
213 DEFINE (Bskip_chars_forward, 0167) \
214 DEFINE (Bskip_chars_backward, 0170) \
215 DEFINE (Bforward_line, 0171) \
216 DEFINE (Bchar_syntax, 0172) \
217 DEFINE (Bbuffer_substring, 0173) \
218 DEFINE (Bdelete_region, 0174) \
219 DEFINE (Bnarrow_to_region, 0175) \
220 DEFINE (Bwiden, 0176) \
221 DEFINE (Bend_of_line, 0177) \
222 \
223 DEFINE (Bconstant2, 0201) \
224 DEFINE (Bgoto, 0202) \
225 DEFINE (Bgotoifnil, 0203) \
226 DEFINE (Bgotoifnonnil, 0204) \
227 DEFINE (Bgotoifnilelsepop, 0205) \
228 DEFINE (Bgotoifnonnilelsepop, 0206) \
229 DEFINE (Breturn, 0207) \
230 DEFINE (Bdiscard, 0210) \
231 DEFINE (Bdup, 0211) \
232 \
233 DEFINE (Bsave_excursion, 0212) \
234 DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \
235 DEFINE (Bsave_restriction, 0214) \
236 DEFINE (Bcatch, 0215) \
237 \
238 DEFINE (Bunwind_protect, 0216) \
239 DEFINE (Bcondition_case, 0217) \
240 DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \
241 DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \
242 \
243 DEFINE (Bunbind_all, 0222) /* Obsolete. Never used. */ \
244 \
245 DEFINE (Bset_marker, 0223) \
246 DEFINE (Bmatch_beginning, 0224) \
247 DEFINE (Bmatch_end, 0225) \
248 DEFINE (Bupcase, 0226) \
249 DEFINE (Bdowncase, 0227) \
250 \
251 DEFINE (Bstringeqlsign, 0230) \
252 DEFINE (Bstringlss, 0231) \
253 DEFINE (Bequal, 0232) \
254 DEFINE (Bnthcdr, 0233) \
255 DEFINE (Belt, 0234) \
256 DEFINE (Bmember, 0235) \
257 DEFINE (Bassq, 0236) \
258 DEFINE (Bnreverse, 0237) \
259 DEFINE (Bsetcar, 0240) \
260 DEFINE (Bsetcdr, 0241) \
261 DEFINE (Bcar_safe, 0242) \
262 DEFINE (Bcdr_safe, 0243) \
263 DEFINE (Bnconc, 0244) \
264 DEFINE (Bquo, 0245) \
265 DEFINE (Brem, 0246) \
266 DEFINE (Bnumberp, 0247) \
267 DEFINE (Bintegerp, 0250) \
268 \
269 DEFINE (BRgoto, 0252) \
270 DEFINE (BRgotoifnil, 0253) \
271 DEFINE (BRgotoifnonnil, 0254) \
272 DEFINE (BRgotoifnilelsepop, 0255) \
273 DEFINE (BRgotoifnonnilelsepop, 0256) \
274 \
275 DEFINE (BlistN, 0257) \
276 DEFINE (BconcatN, 0260) \
277 DEFINE (BinsertN, 0261) \
278 \
279 /* Bstack_ref is code 0. */ \
280 DEFINE (Bstack_set, 0262) \
281 DEFINE (Bstack_set2, 0263) \
282 DEFINE (BdiscardN, 0266) \
283 \
284 DEFINE (Bconstant, 0300)
285
286 enum byte_code_op
287 {
288 #define DEFINE(name, value) name = value,
289 BYTE_CODES
290 #undef DEFINE
291
292 #ifdef BYTE_CODE_SAFE
293 Bscan_buffer = 0153, /* No longer generated as of v18. */
294 Bset_mark = 0163, /* this loser is no longer generated as of v18 */
295 #endif
296 };
297
298 /* Whether to maintain a `top' and `bottom' field in the stack frame. */
299 #define BYTE_MAINTAIN_TOP BYTE_CODE_SAFE
300 \f
301 /* Structure describing a value stack used during byte-code execution
302 in Fbyte_code. */
303
304 struct byte_stack
305 {
306 /* Program counter. This points into the byte_string below
307 and is relocated when that string is relocated. */
308 const unsigned char *pc;
309
310 /* Top and bottom of stack. The bottom points to an area of memory
311 allocated with alloca in Fbyte_code. */
312 #if BYTE_MAINTAIN_TOP
313 Lisp_Object *top, *bottom;
314 #endif
315
316 /* The string containing the byte-code, and its current address.
317 Storing this here protects it from GC because mark_byte_stack
318 marks it. */
319 Lisp_Object byte_string;
320 const unsigned char *byte_string_start;
321
322 /* Next entry in byte_stack_list. */
323 struct byte_stack *next;
324 };
325
326 /* A list of currently active byte-code execution value stacks.
327 Fbyte_code adds an entry to the head of this list before it starts
328 processing byte-code, and it removes the entry again when it is
329 done. Signaling an error truncates the list. */
330
331 struct byte_stack *byte_stack_list;
332
333 \f
334 /* Relocate program counters in the stacks on byte_stack_list. Called
335 when GC has completed. */
336
337 void
338 relocate_byte_stack (void)
339 {
340 struct byte_stack *stack;
341
342 for (stack = byte_stack_list; stack; stack = stack->next)
343 {
344 if (stack->byte_string_start != SDATA (stack->byte_string))
345 {
346 ptrdiff_t offset = stack->pc - stack->byte_string_start;
347 stack->byte_string_start = SDATA (stack->byte_string);
348 stack->pc = stack->byte_string_start + offset;
349 }
350 }
351 }
352
353 \f
354 /* Fetch the next byte from the bytecode stream. */
355
356 #ifdef BYTE_CODE_SAFE
357 #define FETCH (eassert (stack.byte_string_start == SDATA (stack.byte_string)), *stack.pc++)
358 #else
359 #define FETCH *stack.pc++
360 #endif
361
362 /* Fetch two bytes from the bytecode stream and make a 16-bit number
363 out of them. */
364
365 #define FETCH2 (op = FETCH, op + (FETCH << 8))
366
367 /* Push x onto the execution stack. This used to be #define PUSH(x)
368 (*++stackp = (x)) This oddity is necessary because Alliant can't be
369 bothered to compile the preincrement operator properly, as of 4/91.
370 -JimB */
371
372 #define PUSH(x) (top++, *top = (x))
373
374 /* Pop a value off the execution stack. */
375
376 #define POP (*top--)
377
378 /* Discard n values from the execution stack. */
379
380 #define DISCARD(n) (top -= (n))
381
382 /* Get the value which is at the top of the execution stack, but don't
383 pop it. */
384
385 #define TOP (*top)
386
387 /* Actions that must be performed before and after calling a function
388 that might GC. */
389
390 #if !BYTE_MAINTAIN_TOP
391 #define BEFORE_POTENTIAL_GC() ((void)0)
392 #define AFTER_POTENTIAL_GC() ((void)0)
393 #else
394 #define BEFORE_POTENTIAL_GC() stack.top = top
395 #define AFTER_POTENTIAL_GC() stack.top = NULL
396 #endif
397
398 /* Garbage collect if we have consed enough since the last time.
399 We do this at every branch, to avoid loops that never GC. */
400
401 #define MAYBE_GC() \
402 do { \
403 BEFORE_POTENTIAL_GC (); \
404 maybe_gc (); \
405 AFTER_POTENTIAL_GC (); \
406 } while (0)
407
408 /* Check for jumping out of range. */
409
410 #ifdef BYTE_CODE_SAFE
411
412 #define CHECK_RANGE(ARG) \
413 if (ARG >= bytestr_length) emacs_abort ()
414
415 #else /* not BYTE_CODE_SAFE */
416
417 #define CHECK_RANGE(ARG)
418
419 #endif /* not BYTE_CODE_SAFE */
420
421 /* A version of the QUIT macro which makes sure that the stack top is
422 set before signaling `quit'. */
423
424 #define BYTE_CODE_QUIT \
425 do { \
426 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \
427 { \
428 Lisp_Object flag = Vquit_flag; \
429 Vquit_flag = Qnil; \
430 BEFORE_POTENTIAL_GC (); \
431 if (EQ (Vthrow_on_input, flag)) \
432 Fthrow (Vthrow_on_input, Qt); \
433 Fsignal (Qquit, Qnil); \
434 AFTER_POTENTIAL_GC (); \
435 } \
436 else if (pending_signals) \
437 process_pending_signals (); \
438 } while (0)
439
440
441 DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
442 doc: /* Function used internally in byte-compiled code.
443 The first argument, BYTESTR, is a string of byte code;
444 the second, VECTOR, a vector of constants;
445 the third, MAXDEPTH, the maximum stack depth used in this function.
446 If the third argument is incorrect, Emacs may crash. */)
447 (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth)
448 {
449 return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL);
450 }
451
452 static void
453 bcall0 (Lisp_Object f)
454 {
455 Ffuncall (1, &f);
456 }
457
458 /* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and
459 MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect,
460 emacs may crash!). If ARGS_TEMPLATE is non-nil, it should be a lisp
461 argument list (including &rest, &optional, etc.), and ARGS, of size
462 NARGS, should be a vector of the actual arguments. The arguments in
463 ARGS are pushed on the stack according to ARGS_TEMPLATE before
464 executing BYTESTR. */
465
466 Lisp_Object
467 exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
468 Lisp_Object args_template, ptrdiff_t nargs, Lisp_Object *args)
469 {
470 ptrdiff_t count = SPECPDL_INDEX ();
471 #ifdef BYTE_CODE_METER
472 int volatile this_op = 0;
473 int prev_op;
474 #endif
475 int op;
476 /* Lisp_Object v1, v2; */
477 Lisp_Object *vectorp;
478 #ifdef BYTE_CODE_SAFE
479 ptrdiff_t const_length;
480 Lisp_Object *stacke;
481 ptrdiff_t bytestr_length;
482 #endif
483 struct byte_stack stack;
484 Lisp_Object *top;
485 Lisp_Object result;
486 enum handlertype type;
487
488 #if 0 /* CHECK_FRAME_FONT */
489 {
490 struct frame *f = SELECTED_FRAME ();
491 if (FRAME_X_P (f)
492 && FRAME_FONT (f)->direction != 0
493 && FRAME_FONT (f)->direction != 1)
494 emacs_abort ();
495 }
496 #endif
497
498 CHECK_STRING (bytestr);
499 CHECK_VECTOR (vector);
500 CHECK_NATNUM (maxdepth);
501
502 #ifdef BYTE_CODE_SAFE
503 const_length = ASIZE (vector);
504 #endif
505
506 if (STRING_MULTIBYTE (bytestr))
507 /* BYTESTR must have been produced by Emacs 20.2 or the earlier
508 because they produced a raw 8-bit string for byte-code and now
509 such a byte-code string is loaded as multibyte while raw 8-bit
510 characters converted to multibyte form. Thus, now we must
511 convert them back to the originally intended unibyte form. */
512 bytestr = Fstring_as_unibyte (bytestr);
513
514 #ifdef BYTE_CODE_SAFE
515 bytestr_length = SBYTES (bytestr);
516 #endif
517 vectorp = XVECTOR (vector)->contents;
518
519 stack.byte_string = bytestr;
520 stack.pc = stack.byte_string_start = SDATA (bytestr);
521 if (MAX_ALLOCA / word_size <= XFASTINT (maxdepth))
522 memory_full (SIZE_MAX);
523 top = alloca ((XFASTINT (maxdepth) + 1) * sizeof *top);
524 #if BYTE_MAINTAIN_TOP
525 stack.bottom = top + 1;
526 stack.top = NULL;
527 #endif
528 stack.next = byte_stack_list;
529 byte_stack_list = &stack;
530
531 #ifdef BYTE_CODE_SAFE
532 stacke = stack.bottom - 1 + XFASTINT (maxdepth);
533 #endif
534
535 if (INTEGERP (args_template))
536 {
537 ptrdiff_t at = XINT (args_template);
538 bool rest = (at & 128) != 0;
539 int mandatory = at & 127;
540 ptrdiff_t nonrest = at >> 8;
541 eassert (mandatory <= nonrest);
542 if (nargs <= nonrest)
543 {
544 ptrdiff_t i;
545 for (i = 0 ; i < nargs; i++, args++)
546 PUSH (*args);
547 if (nargs < mandatory)
548 /* Too few arguments. */
549 Fsignal (Qwrong_number_of_arguments,
550 list2 (Fcons (make_number (mandatory),
551 rest ? Qand_rest : make_number (nonrest)),
552 make_number (nargs)));
553 else
554 {
555 for (; i < nonrest; i++)
556 PUSH (Qnil);
557 if (rest)
558 PUSH (Qnil);
559 }
560 }
561 else if (rest)
562 {
563 ptrdiff_t i;
564 for (i = 0 ; i < nonrest; i++, args++)
565 PUSH (*args);
566 PUSH (Flist (nargs - nonrest, args));
567 }
568 else
569 /* Too many arguments. */
570 Fsignal (Qwrong_number_of_arguments,
571 list2 (Fcons (make_number (mandatory), make_number (nonrest)),
572 make_number (nargs)));
573 }
574 else if (! NILP (args_template))
575 /* We should push some arguments on the stack. */
576 {
577 error ("Unknown args template!");
578 }
579
580 while (1)
581 {
582 #ifdef BYTE_CODE_SAFE
583 if (top > stacke)
584 emacs_abort ();
585 else if (top < stack.bottom - 1)
586 emacs_abort ();
587 #endif
588
589 #ifdef BYTE_CODE_METER
590 prev_op = this_op;
591 this_op = op = FETCH;
592 METER_CODE (prev_op, op);
593 #else
594 #ifndef BYTE_CODE_THREADED
595 op = FETCH;
596 #endif
597 #endif
598
599 /* The interpreter can be compiled one of two ways: as an
600 ordinary switch-based interpreter, or as a threaded
601 interpreter. The threaded interpreter relies on GCC's
602 computed goto extension, so it is not available everywhere.
603 Threading provides a performance boost. These macros are how
604 we allow the code to be compiled both ways. */
605 #ifdef BYTE_CODE_THREADED
606 /* The CASE macro introduces an instruction's body. It is
607 either a label or a case label. */
608 #define CASE(OP) insn_ ## OP
609 /* NEXT is invoked at the end of an instruction to go to the
610 next instruction. It is either a computed goto, or a
611 plain break. */
612 #define NEXT goto *(targets[op = FETCH])
613 /* FIRST is like NEXT, but is only used at the start of the
614 interpreter body. In the switch-based interpreter it is the
615 switch, so the threaded definition must include a semicolon. */
616 #define FIRST NEXT;
617 /* Most cases are labeled with the CASE macro, above.
618 CASE_DEFAULT is one exception; it is used if the interpreter
619 being built requires a default case. The threaded
620 interpreter does not, because the dispatch table is
621 completely filled. */
622 #define CASE_DEFAULT
623 /* This introduces an instruction that is known to call abort. */
624 #define CASE_ABORT CASE (Bstack_ref): CASE (default)
625 #else
626 /* See above for the meaning of the various defines. */
627 #define CASE(OP) case OP
628 #define NEXT break
629 #define FIRST switch (op)
630 #define CASE_DEFAULT case 255: default:
631 #define CASE_ABORT case 0
632 #endif
633
634 #ifdef BYTE_CODE_THREADED
635
636 /* A convenience define that saves us a lot of typing and makes
637 the table clearer. */
638 #define LABEL(OP) [OP] = &&insn_ ## OP
639
640 #if 4 < __GNUC__ + (6 <= __GNUC_MINOR__)
641 # pragma GCC diagnostic push
642 # pragma GCC diagnostic ignored "-Woverride-init"
643 #elif defined __clang__
644 # pragma GCC diagnostic push
645 # pragma GCC diagnostic ignored "-Winitializer-overrides"
646 #endif
647
648 /* This is the dispatch table for the threaded interpreter. */
649 static const void *const targets[256] =
650 {
651 [0 ... (Bconstant - 1)] = &&insn_default,
652 [Bconstant ... 255] = &&insn_Bconstant,
653
654 #define DEFINE(name, value) LABEL (name) ,
655 BYTE_CODES
656 #undef DEFINE
657 };
658
659 #if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) || defined __clang__
660 # pragma GCC diagnostic pop
661 #endif
662
663 #endif
664
665
666 FIRST
667 {
668 CASE (Bvarref7):
669 op = FETCH2;
670 goto varref;
671
672 CASE (Bvarref):
673 CASE (Bvarref1):
674 CASE (Bvarref2):
675 CASE (Bvarref3):
676 CASE (Bvarref4):
677 CASE (Bvarref5):
678 op = op - Bvarref;
679 goto varref;
680
681 /* This seems to be the most frequently executed byte-code
682 among the Bvarref's, so avoid a goto here. */
683 CASE (Bvarref6):
684 op = FETCH;
685 varref:
686 {
687 Lisp_Object v1, v2;
688
689 v1 = vectorp[op];
690 if (SYMBOLP (v1))
691 {
692 if (XSYMBOL (v1)->redirect != SYMBOL_PLAINVAL
693 || (v2 = SYMBOL_VAL (XSYMBOL (v1)),
694 EQ (v2, Qunbound)))
695 {
696 BEFORE_POTENTIAL_GC ();
697 v2 = Fsymbol_value (v1);
698 AFTER_POTENTIAL_GC ();
699 }
700 }
701 else
702 {
703 BEFORE_POTENTIAL_GC ();
704 v2 = Fsymbol_value (v1);
705 AFTER_POTENTIAL_GC ();
706 }
707 PUSH (v2);
708 NEXT;
709 }
710
711 CASE (Bgotoifnil):
712 {
713 Lisp_Object v1;
714 MAYBE_GC ();
715 op = FETCH2;
716 v1 = POP;
717 if (NILP (v1))
718 {
719 BYTE_CODE_QUIT;
720 CHECK_RANGE (op);
721 stack.pc = stack.byte_string_start + op;
722 }
723 NEXT;
724 }
725
726 CASE (Bcar):
727 {
728 Lisp_Object v1;
729 v1 = TOP;
730 if (CONSP (v1))
731 TOP = XCAR (v1);
732 else if (NILP (v1))
733 TOP = Qnil;
734 else
735 {
736 BEFORE_POTENTIAL_GC ();
737 wrong_type_argument (Qlistp, v1);
738 }
739 NEXT;
740 }
741
742 CASE (Beq):
743 {
744 Lisp_Object v1;
745 v1 = POP;
746 TOP = EQ (v1, TOP) ? Qt : Qnil;
747 NEXT;
748 }
749
750 CASE (Bmemq):
751 {
752 Lisp_Object v1;
753 BEFORE_POTENTIAL_GC ();
754 v1 = POP;
755 TOP = Fmemq (TOP, v1);
756 AFTER_POTENTIAL_GC ();
757 NEXT;
758 }
759
760 CASE (Bcdr):
761 {
762 Lisp_Object v1;
763 v1 = TOP;
764 if (CONSP (v1))
765 TOP = XCDR (v1);
766 else if (NILP (v1))
767 TOP = Qnil;
768 else
769 {
770 BEFORE_POTENTIAL_GC ();
771 wrong_type_argument (Qlistp, v1);
772 }
773 NEXT;
774 }
775
776 CASE (Bvarset):
777 CASE (Bvarset1):
778 CASE (Bvarset2):
779 CASE (Bvarset3):
780 CASE (Bvarset4):
781 CASE (Bvarset5):
782 op -= Bvarset;
783 goto varset;
784
785 CASE (Bvarset7):
786 op = FETCH2;
787 goto varset;
788
789 CASE (Bvarset6):
790 op = FETCH;
791 varset:
792 {
793 Lisp_Object sym, val;
794
795 sym = vectorp[op];
796 val = TOP;
797
798 /* Inline the most common case. */
799 if (SYMBOLP (sym)
800 && !EQ (val, Qunbound)
801 && !XSYMBOL (sym)->redirect
802 && !SYMBOL_CONSTANT_P (sym))
803 SET_SYMBOL_VAL (XSYMBOL (sym), val);
804 else
805 {
806 BEFORE_POTENTIAL_GC ();
807 set_internal (sym, val, Qnil, 0);
808 AFTER_POTENTIAL_GC ();
809 }
810 }
811 (void) POP;
812 NEXT;
813
814 CASE (Bdup):
815 {
816 Lisp_Object v1;
817 v1 = TOP;
818 PUSH (v1);
819 NEXT;
820 }
821
822 /* ------------------ */
823
824 CASE (Bvarbind6):
825 op = FETCH;
826 goto varbind;
827
828 CASE (Bvarbind7):
829 op = FETCH2;
830 goto varbind;
831
832 CASE (Bvarbind):
833 CASE (Bvarbind1):
834 CASE (Bvarbind2):
835 CASE (Bvarbind3):
836 CASE (Bvarbind4):
837 CASE (Bvarbind5):
838 op -= Bvarbind;
839 varbind:
840 /* Specbind can signal and thus GC. */
841 BEFORE_POTENTIAL_GC ();
842 specbind (vectorp[op], POP);
843 AFTER_POTENTIAL_GC ();
844 NEXT;
845
846 CASE (Bcall6):
847 op = FETCH;
848 goto docall;
849
850 CASE (Bcall7):
851 op = FETCH2;
852 goto docall;
853
854 CASE (Bcall):
855 CASE (Bcall1):
856 CASE (Bcall2):
857 CASE (Bcall3):
858 CASE (Bcall4):
859 CASE (Bcall5):
860 op -= Bcall;
861 docall:
862 {
863 BEFORE_POTENTIAL_GC ();
864 DISCARD (op);
865 #ifdef BYTE_CODE_METER
866 if (byte_metering_on && SYMBOLP (TOP))
867 {
868 Lisp_Object v1, v2;
869
870 v1 = TOP;
871 v2 = Fget (v1, Qbyte_code_meter);
872 if (INTEGERP (v2)
873 && XINT (v2) < MOST_POSITIVE_FIXNUM)
874 {
875 XSETINT (v2, XINT (v2) + 1);
876 Fput (v1, Qbyte_code_meter, v2);
877 }
878 }
879 #endif
880 TOP = Ffuncall (op + 1, &TOP);
881 AFTER_POTENTIAL_GC ();
882 NEXT;
883 }
884
885 CASE (Bunbind6):
886 op = FETCH;
887 goto dounbind;
888
889 CASE (Bunbind7):
890 op = FETCH2;
891 goto dounbind;
892
893 CASE (Bunbind):
894 CASE (Bunbind1):
895 CASE (Bunbind2):
896 CASE (Bunbind3):
897 CASE (Bunbind4):
898 CASE (Bunbind5):
899 op -= Bunbind;
900 dounbind:
901 BEFORE_POTENTIAL_GC ();
902 unbind_to (SPECPDL_INDEX () - op, Qnil);
903 AFTER_POTENTIAL_GC ();
904 NEXT;
905
906 CASE (Bunbind_all): /* Obsolete. Never used. */
907 /* To unbind back to the beginning of this frame. Not used yet,
908 but will be needed for tail-recursion elimination. */
909 BEFORE_POTENTIAL_GC ();
910 unbind_to (count, Qnil);
911 AFTER_POTENTIAL_GC ();
912 NEXT;
913
914 CASE (Bgoto):
915 MAYBE_GC ();
916 BYTE_CODE_QUIT;
917 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
918 CHECK_RANGE (op);
919 stack.pc = stack.byte_string_start + op;
920 NEXT;
921
922 CASE (Bgotoifnonnil):
923 {
924 Lisp_Object v1;
925 MAYBE_GC ();
926 op = FETCH2;
927 v1 = POP;
928 if (!NILP (v1))
929 {
930 BYTE_CODE_QUIT;
931 CHECK_RANGE (op);
932 stack.pc = stack.byte_string_start + op;
933 }
934 NEXT;
935 }
936
937 CASE (Bgotoifnilelsepop):
938 MAYBE_GC ();
939 op = FETCH2;
940 if (NILP (TOP))
941 {
942 BYTE_CODE_QUIT;
943 CHECK_RANGE (op);
944 stack.pc = stack.byte_string_start + op;
945 }
946 else DISCARD (1);
947 NEXT;
948
949 CASE (Bgotoifnonnilelsepop):
950 MAYBE_GC ();
951 op = FETCH2;
952 if (!NILP (TOP))
953 {
954 BYTE_CODE_QUIT;
955 CHECK_RANGE (op);
956 stack.pc = stack.byte_string_start + op;
957 }
958 else DISCARD (1);
959 NEXT;
960
961 CASE (BRgoto):
962 MAYBE_GC ();
963 BYTE_CODE_QUIT;
964 stack.pc += (int) *stack.pc - 127;
965 NEXT;
966
967 CASE (BRgotoifnil):
968 {
969 Lisp_Object v1;
970 MAYBE_GC ();
971 v1 = POP;
972 if (NILP (v1))
973 {
974 BYTE_CODE_QUIT;
975 stack.pc += (int) *stack.pc - 128;
976 }
977 stack.pc++;
978 NEXT;
979 }
980
981 CASE (BRgotoifnonnil):
982 {
983 Lisp_Object v1;
984 MAYBE_GC ();
985 v1 = POP;
986 if (!NILP (v1))
987 {
988 BYTE_CODE_QUIT;
989 stack.pc += (int) *stack.pc - 128;
990 }
991 stack.pc++;
992 NEXT;
993 }
994
995 CASE (BRgotoifnilelsepop):
996 MAYBE_GC ();
997 op = *stack.pc++;
998 if (NILP (TOP))
999 {
1000 BYTE_CODE_QUIT;
1001 stack.pc += op - 128;
1002 }
1003 else DISCARD (1);
1004 NEXT;
1005
1006 CASE (BRgotoifnonnilelsepop):
1007 MAYBE_GC ();
1008 op = *stack.pc++;
1009 if (!NILP (TOP))
1010 {
1011 BYTE_CODE_QUIT;
1012 stack.pc += op - 128;
1013 }
1014 else DISCARD (1);
1015 NEXT;
1016
1017 CASE (Breturn):
1018 result = POP;
1019 goto exit;
1020
1021 CASE (Bdiscard):
1022 DISCARD (1);
1023 NEXT;
1024
1025 CASE (Bconstant2):
1026 PUSH (vectorp[FETCH2]);
1027 NEXT;
1028
1029 CASE (Bsave_excursion):
1030 record_unwind_protect (save_excursion_restore,
1031 save_excursion_save ());
1032 NEXT;
1033
1034 CASE (Bsave_current_buffer): /* Obsolete since ??. */
1035 CASE (Bsave_current_buffer_1):
1036 record_unwind_current_buffer ();
1037 NEXT;
1038
1039 CASE (Bsave_window_excursion): /* Obsolete since 24.1. */
1040 {
1041 ptrdiff_t count1 = SPECPDL_INDEX ();
1042 record_unwind_protect (restore_window_configuration,
1043 Fcurrent_window_configuration (Qnil));
1044 BEFORE_POTENTIAL_GC ();
1045 TOP = Fprogn (TOP);
1046 unbind_to (count1, TOP);
1047 AFTER_POTENTIAL_GC ();
1048 NEXT;
1049 }
1050
1051 CASE (Bsave_restriction):
1052 record_unwind_protect (save_restriction_restore,
1053 save_restriction_save ());
1054 NEXT;
1055
1056 CASE (Bcatch): /* Obsolete since 24.4. */
1057 {
1058 Lisp_Object v1;
1059 BEFORE_POTENTIAL_GC ();
1060 v1 = POP;
1061 TOP = internal_catch (TOP, eval_sub, v1);
1062 AFTER_POTENTIAL_GC ();
1063 NEXT;
1064 }
1065
1066 CASE (Bpushcatch): /* New in 24.4. */
1067 type = CATCHER;
1068 goto pushhandler;
1069 CASE (Bpushconditioncase): /* New in 24.4. */
1070 type = CONDITION_CASE;
1071 pushhandler:
1072 {
1073 Lisp_Object tag = POP;
1074 int dest = FETCH2;
1075
1076 struct handler *c = push_handler (tag, type);
1077 c->bytecode_dest = dest;
1078 c->bytecode_top = top;
1079
1080 if (sys_setjmp (c->jmp))
1081 {
1082 struct handler *c = handlerlist;
1083 int dest;
1084 top = c->bytecode_top;
1085 dest = c->bytecode_dest;
1086 handlerlist = c->next;
1087 PUSH (c->val);
1088 CHECK_RANGE (dest);
1089 /* Might have been re-set by longjmp! */
1090 stack.byte_string_start = SDATA (stack.byte_string);
1091 stack.pc = stack.byte_string_start + dest;
1092 }
1093
1094 NEXT;
1095 }
1096
1097 CASE (Bpophandler): /* New in 24.4. */
1098 {
1099 handlerlist = handlerlist->next;
1100 NEXT;
1101 }
1102
1103 CASE (Bunwind_protect): /* FIXME: avoid closure for lexbind. */
1104 {
1105 Lisp_Object handler = POP;
1106 /* Support for a function here is new in 24.4. */
1107 record_unwind_protect (NILP (Ffunctionp (handler))
1108 ? unwind_body : bcall0,
1109 handler);
1110 NEXT;
1111 }
1112
1113 CASE (Bcondition_case): /* Obsolete since 24.4. */
1114 {
1115 Lisp_Object handlers, body;
1116 handlers = POP;
1117 body = POP;
1118 BEFORE_POTENTIAL_GC ();
1119 TOP = internal_lisp_condition_case (TOP, body, handlers);
1120 AFTER_POTENTIAL_GC ();
1121 NEXT;
1122 }
1123
1124 CASE (Btemp_output_buffer_setup): /* Obsolete since 24.1. */
1125 BEFORE_POTENTIAL_GC ();
1126 CHECK_STRING (TOP);
1127 temp_output_buffer_setup (SSDATA (TOP));
1128 AFTER_POTENTIAL_GC ();
1129 TOP = Vstandard_output;
1130 NEXT;
1131
1132 CASE (Btemp_output_buffer_show): /* Obsolete since 24.1. */
1133 {
1134 Lisp_Object v1;
1135 BEFORE_POTENTIAL_GC ();
1136 v1 = POP;
1137 temp_output_buffer_show (TOP);
1138 TOP = v1;
1139 /* pop binding of standard-output */
1140 unbind_to (SPECPDL_INDEX () - 1, Qnil);
1141 AFTER_POTENTIAL_GC ();
1142 NEXT;
1143 }
1144
1145 CASE (Bnth):
1146 {
1147 Lisp_Object v1, v2;
1148 EMACS_INT n;
1149 BEFORE_POTENTIAL_GC ();
1150 v1 = POP;
1151 v2 = TOP;
1152 CHECK_NUMBER (v2);
1153 n = XINT (v2);
1154 immediate_quit = 1;
1155 while (--n >= 0 && CONSP (v1))
1156 v1 = XCDR (v1);
1157 immediate_quit = 0;
1158 TOP = CAR (v1);
1159 AFTER_POTENTIAL_GC ();
1160 NEXT;
1161 }
1162
1163 CASE (Bsymbolp):
1164 TOP = SYMBOLP (TOP) ? Qt : Qnil;
1165 NEXT;
1166
1167 CASE (Bconsp):
1168 TOP = CONSP (TOP) ? Qt : Qnil;
1169 NEXT;
1170
1171 CASE (Bstringp):
1172 TOP = STRINGP (TOP) ? Qt : Qnil;
1173 NEXT;
1174
1175 CASE (Blistp):
1176 TOP = CONSP (TOP) || NILP (TOP) ? Qt : Qnil;
1177 NEXT;
1178
1179 CASE (Bnot):
1180 TOP = NILP (TOP) ? Qt : Qnil;
1181 NEXT;
1182
1183 CASE (Bcons):
1184 {
1185 Lisp_Object v1;
1186 v1 = POP;
1187 TOP = Fcons (TOP, v1);
1188 NEXT;
1189 }
1190
1191 CASE (Blist1):
1192 TOP = list1 (TOP);
1193 NEXT;
1194
1195 CASE (Blist2):
1196 {
1197 Lisp_Object v1;
1198 v1 = POP;
1199 TOP = list2 (TOP, v1);
1200 NEXT;
1201 }
1202
1203 CASE (Blist3):
1204 DISCARD (2);
1205 TOP = Flist (3, &TOP);
1206 NEXT;
1207
1208 CASE (Blist4):
1209 DISCARD (3);
1210 TOP = Flist (4, &TOP);
1211 NEXT;
1212
1213 CASE (BlistN):
1214 op = FETCH;
1215 DISCARD (op - 1);
1216 TOP = Flist (op, &TOP);
1217 NEXT;
1218
1219 CASE (Blength):
1220 BEFORE_POTENTIAL_GC ();
1221 TOP = Flength (TOP);
1222 AFTER_POTENTIAL_GC ();
1223 NEXT;
1224
1225 CASE (Baref):
1226 {
1227 Lisp_Object v1;
1228 BEFORE_POTENTIAL_GC ();
1229 v1 = POP;
1230 TOP = Faref (TOP, v1);
1231 AFTER_POTENTIAL_GC ();
1232 NEXT;
1233 }
1234
1235 CASE (Baset):
1236 {
1237 Lisp_Object v1, v2;
1238 BEFORE_POTENTIAL_GC ();
1239 v2 = POP; v1 = POP;
1240 TOP = Faset (TOP, v1, v2);
1241 AFTER_POTENTIAL_GC ();
1242 NEXT;
1243 }
1244
1245 CASE (Bsymbol_value):
1246 BEFORE_POTENTIAL_GC ();
1247 TOP = Fsymbol_value (TOP);
1248 AFTER_POTENTIAL_GC ();
1249 NEXT;
1250
1251 CASE (Bsymbol_function):
1252 BEFORE_POTENTIAL_GC ();
1253 TOP = Fsymbol_function (TOP);
1254 AFTER_POTENTIAL_GC ();
1255 NEXT;
1256
1257 CASE (Bset):
1258 {
1259 Lisp_Object v1;
1260 BEFORE_POTENTIAL_GC ();
1261 v1 = POP;
1262 TOP = Fset (TOP, v1);
1263 AFTER_POTENTIAL_GC ();
1264 NEXT;
1265 }
1266
1267 CASE (Bfset):
1268 {
1269 Lisp_Object v1;
1270 BEFORE_POTENTIAL_GC ();
1271 v1 = POP;
1272 TOP = Ffset (TOP, v1);
1273 AFTER_POTENTIAL_GC ();
1274 NEXT;
1275 }
1276
1277 CASE (Bget):
1278 {
1279 Lisp_Object v1;
1280 BEFORE_POTENTIAL_GC ();
1281 v1 = POP;
1282 TOP = Fget (TOP, v1);
1283 AFTER_POTENTIAL_GC ();
1284 NEXT;
1285 }
1286
1287 CASE (Bsubstring):
1288 {
1289 Lisp_Object v1, v2;
1290 BEFORE_POTENTIAL_GC ();
1291 v2 = POP; v1 = POP;
1292 TOP = Fsubstring (TOP, v1, v2);
1293 AFTER_POTENTIAL_GC ();
1294 NEXT;
1295 }
1296
1297 CASE (Bconcat2):
1298 BEFORE_POTENTIAL_GC ();
1299 DISCARD (1);
1300 TOP = Fconcat (2, &TOP);
1301 AFTER_POTENTIAL_GC ();
1302 NEXT;
1303
1304 CASE (Bconcat3):
1305 BEFORE_POTENTIAL_GC ();
1306 DISCARD (2);
1307 TOP = Fconcat (3, &TOP);
1308 AFTER_POTENTIAL_GC ();
1309 NEXT;
1310
1311 CASE (Bconcat4):
1312 BEFORE_POTENTIAL_GC ();
1313 DISCARD (3);
1314 TOP = Fconcat (4, &TOP);
1315 AFTER_POTENTIAL_GC ();
1316 NEXT;
1317
1318 CASE (BconcatN):
1319 op = FETCH;
1320 BEFORE_POTENTIAL_GC ();
1321 DISCARD (op - 1);
1322 TOP = Fconcat (op, &TOP);
1323 AFTER_POTENTIAL_GC ();
1324 NEXT;
1325
1326 CASE (Bsub1):
1327 {
1328 Lisp_Object v1;
1329 v1 = TOP;
1330 if (INTEGERP (v1))
1331 {
1332 XSETINT (v1, XINT (v1) - 1);
1333 TOP = v1;
1334 }
1335 else
1336 {
1337 BEFORE_POTENTIAL_GC ();
1338 TOP = Fsub1 (v1);
1339 AFTER_POTENTIAL_GC ();
1340 }
1341 NEXT;
1342 }
1343
1344 CASE (Badd1):
1345 {
1346 Lisp_Object v1;
1347 v1 = TOP;
1348 if (INTEGERP (v1))
1349 {
1350 XSETINT (v1, XINT (v1) + 1);
1351 TOP = v1;
1352 }
1353 else
1354 {
1355 BEFORE_POTENTIAL_GC ();
1356 TOP = Fadd1 (v1);
1357 AFTER_POTENTIAL_GC ();
1358 }
1359 NEXT;
1360 }
1361
1362 CASE (Beqlsign):
1363 {
1364 Lisp_Object v1, v2;
1365 BEFORE_POTENTIAL_GC ();
1366 v2 = POP; v1 = TOP;
1367 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1);
1368 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2);
1369 AFTER_POTENTIAL_GC ();
1370 if (FLOATP (v1) || FLOATP (v2))
1371 {
1372 double f1, f2;
1373
1374 f1 = (FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1));
1375 f2 = (FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2));
1376 TOP = (f1 == f2 ? Qt : Qnil);
1377 }
1378 else
1379 TOP = (XINT (v1) == XINT (v2) ? Qt : Qnil);
1380 NEXT;
1381 }
1382
1383 CASE (Bgtr):
1384 {
1385 Lisp_Object v1;
1386 BEFORE_POTENTIAL_GC ();
1387 v1 = POP;
1388 TOP = arithcompare (TOP, v1, ARITH_GRTR);
1389 AFTER_POTENTIAL_GC ();
1390 NEXT;
1391 }
1392
1393 CASE (Blss):
1394 {
1395 Lisp_Object v1;
1396 BEFORE_POTENTIAL_GC ();
1397 v1 = POP;
1398 TOP = arithcompare (TOP, v1, ARITH_LESS);
1399 AFTER_POTENTIAL_GC ();
1400 NEXT;
1401 }
1402
1403 CASE (Bleq):
1404 {
1405 Lisp_Object v1;
1406 BEFORE_POTENTIAL_GC ();
1407 v1 = POP;
1408 TOP = arithcompare (TOP, v1, ARITH_LESS_OR_EQUAL);
1409 AFTER_POTENTIAL_GC ();
1410 NEXT;
1411 }
1412
1413 CASE (Bgeq):
1414 {
1415 Lisp_Object v1;
1416 BEFORE_POTENTIAL_GC ();
1417 v1 = POP;
1418 TOP = arithcompare (TOP, v1, ARITH_GRTR_OR_EQUAL);
1419 AFTER_POTENTIAL_GC ();
1420 NEXT;
1421 }
1422
1423 CASE (Bdiff):
1424 BEFORE_POTENTIAL_GC ();
1425 DISCARD (1);
1426 TOP = Fminus (2, &TOP);
1427 AFTER_POTENTIAL_GC ();
1428 NEXT;
1429
1430 CASE (Bnegate):
1431 {
1432 Lisp_Object v1;
1433 v1 = TOP;
1434 if (INTEGERP (v1))
1435 {
1436 XSETINT (v1, - XINT (v1));
1437 TOP = v1;
1438 }
1439 else
1440 {
1441 BEFORE_POTENTIAL_GC ();
1442 TOP = Fminus (1, &TOP);
1443 AFTER_POTENTIAL_GC ();
1444 }
1445 NEXT;
1446 }
1447
1448 CASE (Bplus):
1449 BEFORE_POTENTIAL_GC ();
1450 DISCARD (1);
1451 TOP = Fplus (2, &TOP);
1452 AFTER_POTENTIAL_GC ();
1453 NEXT;
1454
1455 CASE (Bmax):
1456 BEFORE_POTENTIAL_GC ();
1457 DISCARD (1);
1458 TOP = Fmax (2, &TOP);
1459 AFTER_POTENTIAL_GC ();
1460 NEXT;
1461
1462 CASE (Bmin):
1463 BEFORE_POTENTIAL_GC ();
1464 DISCARD (1);
1465 TOP = Fmin (2, &TOP);
1466 AFTER_POTENTIAL_GC ();
1467 NEXT;
1468
1469 CASE (Bmult):
1470 BEFORE_POTENTIAL_GC ();
1471 DISCARD (1);
1472 TOP = Ftimes (2, &TOP);
1473 AFTER_POTENTIAL_GC ();
1474 NEXT;
1475
1476 CASE (Bquo):
1477 BEFORE_POTENTIAL_GC ();
1478 DISCARD (1);
1479 TOP = Fquo (2, &TOP);
1480 AFTER_POTENTIAL_GC ();
1481 NEXT;
1482
1483 CASE (Brem):
1484 {
1485 Lisp_Object v1;
1486 BEFORE_POTENTIAL_GC ();
1487 v1 = POP;
1488 TOP = Frem (TOP, v1);
1489 AFTER_POTENTIAL_GC ();
1490 NEXT;
1491 }
1492
1493 CASE (Bpoint):
1494 {
1495 Lisp_Object v1;
1496 XSETFASTINT (v1, PT);
1497 PUSH (v1);
1498 NEXT;
1499 }
1500
1501 CASE (Bgoto_char):
1502 BEFORE_POTENTIAL_GC ();
1503 TOP = Fgoto_char (TOP);
1504 AFTER_POTENTIAL_GC ();
1505 NEXT;
1506
1507 CASE (Binsert):
1508 BEFORE_POTENTIAL_GC ();
1509 TOP = Finsert (1, &TOP);
1510 AFTER_POTENTIAL_GC ();
1511 NEXT;
1512
1513 CASE (BinsertN):
1514 op = FETCH;
1515 BEFORE_POTENTIAL_GC ();
1516 DISCARD (op - 1);
1517 TOP = Finsert (op, &TOP);
1518 AFTER_POTENTIAL_GC ();
1519 NEXT;
1520
1521 CASE (Bpoint_max):
1522 {
1523 Lisp_Object v1;
1524 XSETFASTINT (v1, ZV);
1525 PUSH (v1);
1526 NEXT;
1527 }
1528
1529 CASE (Bpoint_min):
1530 {
1531 Lisp_Object v1;
1532 XSETFASTINT (v1, BEGV);
1533 PUSH (v1);
1534 NEXT;
1535 }
1536
1537 CASE (Bchar_after):
1538 BEFORE_POTENTIAL_GC ();
1539 TOP = Fchar_after (TOP);
1540 AFTER_POTENTIAL_GC ();
1541 NEXT;
1542
1543 CASE (Bfollowing_char):
1544 {
1545 Lisp_Object v1;
1546 BEFORE_POTENTIAL_GC ();
1547 v1 = Ffollowing_char ();
1548 AFTER_POTENTIAL_GC ();
1549 PUSH (v1);
1550 NEXT;
1551 }
1552
1553 CASE (Bpreceding_char):
1554 {
1555 Lisp_Object v1;
1556 BEFORE_POTENTIAL_GC ();
1557 v1 = Fprevious_char ();
1558 AFTER_POTENTIAL_GC ();
1559 PUSH (v1);
1560 NEXT;
1561 }
1562
1563 CASE (Bcurrent_column):
1564 {
1565 Lisp_Object v1;
1566 BEFORE_POTENTIAL_GC ();
1567 XSETFASTINT (v1, current_column ());
1568 AFTER_POTENTIAL_GC ();
1569 PUSH (v1);
1570 NEXT;
1571 }
1572
1573 CASE (Bindent_to):
1574 BEFORE_POTENTIAL_GC ();
1575 TOP = Findent_to (TOP, Qnil);
1576 AFTER_POTENTIAL_GC ();
1577 NEXT;
1578
1579 CASE (Beolp):
1580 PUSH (Feolp ());
1581 NEXT;
1582
1583 CASE (Beobp):
1584 PUSH (Feobp ());
1585 NEXT;
1586
1587 CASE (Bbolp):
1588 PUSH (Fbolp ());
1589 NEXT;
1590
1591 CASE (Bbobp):
1592 PUSH (Fbobp ());
1593 NEXT;
1594
1595 CASE (Bcurrent_buffer):
1596 PUSH (Fcurrent_buffer ());
1597 NEXT;
1598
1599 CASE (Bset_buffer):
1600 BEFORE_POTENTIAL_GC ();
1601 TOP = Fset_buffer (TOP);
1602 AFTER_POTENTIAL_GC ();
1603 NEXT;
1604
1605 CASE (Binteractive_p): /* Obsolete since 24.1. */
1606 BEFORE_POTENTIAL_GC ();
1607 PUSH (call0 (intern ("interactive-p")));
1608 AFTER_POTENTIAL_GC ();
1609 NEXT;
1610
1611 CASE (Bforward_char):
1612 BEFORE_POTENTIAL_GC ();
1613 TOP = Fforward_char (TOP);
1614 AFTER_POTENTIAL_GC ();
1615 NEXT;
1616
1617 CASE (Bforward_word):
1618 BEFORE_POTENTIAL_GC ();
1619 TOP = Fforward_word (TOP);
1620 AFTER_POTENTIAL_GC ();
1621 NEXT;
1622
1623 CASE (Bskip_chars_forward):
1624 {
1625 Lisp_Object v1;
1626 BEFORE_POTENTIAL_GC ();
1627 v1 = POP;
1628 TOP = Fskip_chars_forward (TOP, v1);
1629 AFTER_POTENTIAL_GC ();
1630 NEXT;
1631 }
1632
1633 CASE (Bskip_chars_backward):
1634 {
1635 Lisp_Object v1;
1636 BEFORE_POTENTIAL_GC ();
1637 v1 = POP;
1638 TOP = Fskip_chars_backward (TOP, v1);
1639 AFTER_POTENTIAL_GC ();
1640 NEXT;
1641 }
1642
1643 CASE (Bforward_line):
1644 BEFORE_POTENTIAL_GC ();
1645 TOP = Fforward_line (TOP);
1646 AFTER_POTENTIAL_GC ();
1647 NEXT;
1648
1649 CASE (Bchar_syntax):
1650 {
1651 int c;
1652
1653 BEFORE_POTENTIAL_GC ();
1654 CHECK_CHARACTER (TOP);
1655 AFTER_POTENTIAL_GC ();
1656 c = XFASTINT (TOP);
1657 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
1658 MAKE_CHAR_MULTIBYTE (c);
1659 XSETFASTINT (TOP, syntax_code_spec[SYNTAX (c)]);
1660 }
1661 NEXT;
1662
1663 CASE (Bbuffer_substring):
1664 {
1665 Lisp_Object v1;
1666 BEFORE_POTENTIAL_GC ();
1667 v1 = POP;
1668 TOP = Fbuffer_substring (TOP, v1);
1669 AFTER_POTENTIAL_GC ();
1670 NEXT;
1671 }
1672
1673 CASE (Bdelete_region):
1674 {
1675 Lisp_Object v1;
1676 BEFORE_POTENTIAL_GC ();
1677 v1 = POP;
1678 TOP = Fdelete_region (TOP, v1);
1679 AFTER_POTENTIAL_GC ();
1680 NEXT;
1681 }
1682
1683 CASE (Bnarrow_to_region):
1684 {
1685 Lisp_Object v1;
1686 BEFORE_POTENTIAL_GC ();
1687 v1 = POP;
1688 TOP = Fnarrow_to_region (TOP, v1);
1689 AFTER_POTENTIAL_GC ();
1690 NEXT;
1691 }
1692
1693 CASE (Bwiden):
1694 BEFORE_POTENTIAL_GC ();
1695 PUSH (Fwiden ());
1696 AFTER_POTENTIAL_GC ();
1697 NEXT;
1698
1699 CASE (Bend_of_line):
1700 BEFORE_POTENTIAL_GC ();
1701 TOP = Fend_of_line (TOP);
1702 AFTER_POTENTIAL_GC ();
1703 NEXT;
1704
1705 CASE (Bset_marker):
1706 {
1707 Lisp_Object v1, v2;
1708 BEFORE_POTENTIAL_GC ();
1709 v1 = POP;
1710 v2 = POP;
1711 TOP = Fset_marker (TOP, v2, v1);
1712 AFTER_POTENTIAL_GC ();
1713 NEXT;
1714 }
1715
1716 CASE (Bmatch_beginning):
1717 BEFORE_POTENTIAL_GC ();
1718 TOP = Fmatch_beginning (TOP);
1719 AFTER_POTENTIAL_GC ();
1720 NEXT;
1721
1722 CASE (Bmatch_end):
1723 BEFORE_POTENTIAL_GC ();
1724 TOP = Fmatch_end (TOP);
1725 AFTER_POTENTIAL_GC ();
1726 NEXT;
1727
1728 CASE (Bupcase):
1729 BEFORE_POTENTIAL_GC ();
1730 TOP = Fupcase (TOP);
1731 AFTER_POTENTIAL_GC ();
1732 NEXT;
1733
1734 CASE (Bdowncase):
1735 BEFORE_POTENTIAL_GC ();
1736 TOP = Fdowncase (TOP);
1737 AFTER_POTENTIAL_GC ();
1738 NEXT;
1739
1740 CASE (Bstringeqlsign):
1741 {
1742 Lisp_Object v1;
1743 BEFORE_POTENTIAL_GC ();
1744 v1 = POP;
1745 TOP = Fstring_equal (TOP, v1);
1746 AFTER_POTENTIAL_GC ();
1747 NEXT;
1748 }
1749
1750 CASE (Bstringlss):
1751 {
1752 Lisp_Object v1;
1753 BEFORE_POTENTIAL_GC ();
1754 v1 = POP;
1755 TOP = Fstring_lessp (TOP, v1);
1756 AFTER_POTENTIAL_GC ();
1757 NEXT;
1758 }
1759
1760 CASE (Bequal):
1761 {
1762 Lisp_Object v1;
1763 v1 = POP;
1764 TOP = Fequal (TOP, v1);
1765 NEXT;
1766 }
1767
1768 CASE (Bnthcdr):
1769 {
1770 Lisp_Object v1;
1771 BEFORE_POTENTIAL_GC ();
1772 v1 = POP;
1773 TOP = Fnthcdr (TOP, v1);
1774 AFTER_POTENTIAL_GC ();
1775 NEXT;
1776 }
1777
1778 CASE (Belt):
1779 {
1780 Lisp_Object v1, v2;
1781 if (CONSP (TOP))
1782 {
1783 /* Exchange args and then do nth. */
1784 EMACS_INT n;
1785 BEFORE_POTENTIAL_GC ();
1786 v2 = POP;
1787 v1 = TOP;
1788 CHECK_NUMBER (v2);
1789 AFTER_POTENTIAL_GC ();
1790 n = XINT (v2);
1791 immediate_quit = 1;
1792 while (--n >= 0 && CONSP (v1))
1793 v1 = XCDR (v1);
1794 immediate_quit = 0;
1795 TOP = CAR (v1);
1796 }
1797 else
1798 {
1799 BEFORE_POTENTIAL_GC ();
1800 v1 = POP;
1801 TOP = Felt (TOP, v1);
1802 AFTER_POTENTIAL_GC ();
1803 }
1804 NEXT;
1805 }
1806
1807 CASE (Bmember):
1808 {
1809 Lisp_Object v1;
1810 BEFORE_POTENTIAL_GC ();
1811 v1 = POP;
1812 TOP = Fmember (TOP, v1);
1813 AFTER_POTENTIAL_GC ();
1814 NEXT;
1815 }
1816
1817 CASE (Bassq):
1818 {
1819 Lisp_Object v1;
1820 BEFORE_POTENTIAL_GC ();
1821 v1 = POP;
1822 TOP = Fassq (TOP, v1);
1823 AFTER_POTENTIAL_GC ();
1824 NEXT;
1825 }
1826
1827 CASE (Bnreverse):
1828 BEFORE_POTENTIAL_GC ();
1829 TOP = Fnreverse (TOP);
1830 AFTER_POTENTIAL_GC ();
1831 NEXT;
1832
1833 CASE (Bsetcar):
1834 {
1835 Lisp_Object v1;
1836 BEFORE_POTENTIAL_GC ();
1837 v1 = POP;
1838 TOP = Fsetcar (TOP, v1);
1839 AFTER_POTENTIAL_GC ();
1840 NEXT;
1841 }
1842
1843 CASE (Bsetcdr):
1844 {
1845 Lisp_Object v1;
1846 BEFORE_POTENTIAL_GC ();
1847 v1 = POP;
1848 TOP = Fsetcdr (TOP, v1);
1849 AFTER_POTENTIAL_GC ();
1850 NEXT;
1851 }
1852
1853 CASE (Bcar_safe):
1854 {
1855 Lisp_Object v1;
1856 v1 = TOP;
1857 TOP = CAR_SAFE (v1);
1858 NEXT;
1859 }
1860
1861 CASE (Bcdr_safe):
1862 {
1863 Lisp_Object v1;
1864 v1 = TOP;
1865 TOP = CDR_SAFE (v1);
1866 NEXT;
1867 }
1868
1869 CASE (Bnconc):
1870 BEFORE_POTENTIAL_GC ();
1871 DISCARD (1);
1872 TOP = Fnconc (2, &TOP);
1873 AFTER_POTENTIAL_GC ();
1874 NEXT;
1875
1876 CASE (Bnumberp):
1877 TOP = (NUMBERP (TOP) ? Qt : Qnil);
1878 NEXT;
1879
1880 CASE (Bintegerp):
1881 TOP = INTEGERP (TOP) ? Qt : Qnil;
1882 NEXT;
1883
1884 #ifdef BYTE_CODE_SAFE
1885 /* These are intentionally written using 'case' syntax,
1886 because they are incompatible with the threaded
1887 interpreter. */
1888
1889 case Bset_mark:
1890 BEFORE_POTENTIAL_GC ();
1891 error ("set-mark is an obsolete bytecode");
1892 AFTER_POTENTIAL_GC ();
1893 break;
1894 case Bscan_buffer:
1895 BEFORE_POTENTIAL_GC ();
1896 error ("scan-buffer is an obsolete bytecode");
1897 AFTER_POTENTIAL_GC ();
1898 break;
1899 #endif
1900
1901 CASE_ABORT:
1902 /* Actually this is Bstack_ref with offset 0, but we use Bdup
1903 for that instead. */
1904 /* CASE (Bstack_ref): */
1905 call3 (Qerror,
1906 build_string ("Invalid byte opcode: op=%s, ptr=%d"),
1907 make_number (op),
1908 make_number ((stack.pc - 1) - stack.byte_string_start));
1909
1910 /* Handy byte-codes for lexical binding. */
1911 CASE (Bstack_ref1):
1912 CASE (Bstack_ref2):
1913 CASE (Bstack_ref3):
1914 CASE (Bstack_ref4):
1915 CASE (Bstack_ref5):
1916 {
1917 Lisp_Object *ptr = top - (op - Bstack_ref);
1918 PUSH (*ptr);
1919 NEXT;
1920 }
1921 CASE (Bstack_ref6):
1922 {
1923 Lisp_Object *ptr = top - (FETCH);
1924 PUSH (*ptr);
1925 NEXT;
1926 }
1927 CASE (Bstack_ref7):
1928 {
1929 Lisp_Object *ptr = top - (FETCH2);
1930 PUSH (*ptr);
1931 NEXT;
1932 }
1933 CASE (Bstack_set):
1934 /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */
1935 {
1936 Lisp_Object *ptr = top - (FETCH);
1937 *ptr = POP;
1938 NEXT;
1939 }
1940 CASE (Bstack_set2):
1941 {
1942 Lisp_Object *ptr = top - (FETCH2);
1943 *ptr = POP;
1944 NEXT;
1945 }
1946 CASE (BdiscardN):
1947 op = FETCH;
1948 if (op & 0x80)
1949 {
1950 op &= 0x7F;
1951 top[-op] = TOP;
1952 }
1953 DISCARD (op);
1954 NEXT;
1955
1956 CASE_DEFAULT
1957 CASE (Bconstant):
1958 #ifdef BYTE_CODE_SAFE
1959 if (op < Bconstant)
1960 {
1961 emacs_abort ();
1962 }
1963 if ((op -= Bconstant) >= const_length)
1964 {
1965 emacs_abort ();
1966 }
1967 PUSH (vectorp[op]);
1968 #else
1969 PUSH (vectorp[op - Bconstant]);
1970 #endif
1971 NEXT;
1972 }
1973 }
1974
1975 exit:
1976
1977 byte_stack_list = byte_stack_list->next;
1978
1979 /* Binds and unbinds are supposed to be compiled balanced. */
1980 if (SPECPDL_INDEX () != count)
1981 {
1982 if (SPECPDL_INDEX () > count)
1983 unbind_to (count, Qnil);
1984 error ("binding stack not balanced (serious byte compiler bug)");
1985 }
1986
1987 return result;
1988 }
1989
1990 void
1991 syms_of_bytecode (void)
1992 {
1993 defsubr (&Sbyte_code);
1994
1995 #ifdef BYTE_CODE_METER
1996
1997 DEFVAR_LISP ("byte-code-meter", Vbyte_code_meter,
1998 doc: /* A vector of vectors which holds a histogram of byte-code usage.
1999 (aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2000 opcode CODE has been executed.
2001 (aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2002 indicates how many times the byte opcodes CODE1 and CODE2 have been
2003 executed in succession. */);
2004
2005 DEFVAR_BOOL ("byte-metering-on", byte_metering_on,
2006 doc: /* If non-nil, keep profiling information on byte code usage.
2007 The variable byte-code-meter indicates how often each byte opcode is used.
2008 If a symbol has a property named `byte-code-meter' whose value is an
2009 integer, it is incremented each time that symbol's function is called. */);
2010
2011 byte_metering_on = 0;
2012 Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
2013 DEFSYM (Qbyte_code_meter, "byte-code-meter");
2014 {
2015 int i = 256;
2016 while (i--)
2017 ASET (Vbyte_code_meter, i,
2018 Fmake_vector (make_number (256), make_number (0)));
2019 }
2020 #endif
2021 }
Emacs repository mirror