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