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