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