Mercurial > hg > xemacs-beta

comparison src/bytecode.c @ 4921:17362f371cc2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
add more byte-code assertions and better failure output -------------------- ChangeLog entries follow: -------------------- src/ChangeLog addition: 2010-02-03 Ben Wing <ben@xemacs.org> * alloc.c (Fmake_byte_code): * bytecode.h: * lisp.h: * lread.c: * lread.c (readevalloop): * lread.c (Fread): * lread.c (Fread_from_string): * lread.c (read_list_conser): * lread.c (read_list): * lread.c (vars_of_lread): * symbols.c: * symbols.c (Fdefine_function): Turn on the "compiled-function annotation hack". Implement it properly by hooking into Fdefalias(). Note in the docstring to `defalias' that we do this. Remove some old broken code and change code that implemented the old kludgy way of hooking into the Lisp reader into bracketed by `#ifdef COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY', which is not enabled. Also enable byte-code metering when DEBUG_XEMACS -- this is a form of profiling for computing histograms of which sequences of two bytecodes are used most often. * bytecode-ops.h: * bytecode-ops.h (OPCODE): New file. Extract out all the opcodes and declare them using OPCODE(), a bit like frame slots and such. This way the file can be included multiple times if necessary to iterate multiple times over the byte opcodes. * bytecode.c: * bytecode.c (NUM_REMEMBERED_BYTE_OPS): * bytecode.c (OPCODE): * bytecode.c (assert_failed_with_remembered_ops): * bytecode.c (READ_UINT_2): * bytecode.c (READ_INT_1): * bytecode.c (READ_INT_2): * bytecode.c (PEEK_INT_1): * bytecode.c (PEEK_INT_2): * bytecode.c (JUMP_RELATIVE): * bytecode.c (JUMP_NEXT): * bytecode.c (PUSH): * bytecode.c (POP_WITH_MULTIPLE_VALUES): * bytecode.c (DISCARD): * bytecode.c (UNUSED): * bytecode.c (optimize_byte_code): * bytecode.c (optimize_compiled_function): * bytecode.c (Fbyte_code): * bytecode.c (vars_of_bytecode): * bytecode.c (init_opcode_table_multi_op): * bytecode.c (reinit_vars_of_bytecode): * emacs.c (main_1): * eval.c (funcall_compiled_function): * symsinit.h: Any time we change either the instruction pointer or the stack pointer, assert that we're going to move it to a valid location. This should catch failures right when they occur rather than sometime later. This requires that we pass in another couple of parameters into some functions (only with error-checking enabled, see below). Also keep track, using a circular queue, of the last 100 byte opcodes seen, and when we hit an assert failure during byte-code execution, output the contents of the queue in a nice readable fashion. This requires that bytecode-ops.h be included a second time so that a table mapping opcodes to the name of their operation can be constructed. This table is constructed in new function reinit_vars_of_bytecode(). Everything in the last two paras happens only when ERROR_CHECK_BYTE_CODE. Add some longish comments describing how the arrays that hold the stack and instructions, and the pointers used to access them, work. * gc.c: Import some code from my `latest-fix' workspace to mark the staticpro's in order from lowest to highest, rather than highest to lowest, so it's easier to debug when something goes wrong. * lisp.h (abort_with_message): Renamed from abort_with_msg(). * symbols.c (defsymbol_massage_name_1): * symbols.c (defsymbol_nodump): * symbols.c (defsymbol): * symbols.c (defkeyword): * symeval.h (DEFVAR_SYMVAL_FWD_OBJECT): Make the various calls to staticpro() instead call staticpro_1(), passing in the name of the C var being staticpro'ed, so that it shows up in staticpro_names. Otherwise staticpro_names just has 1000+ copies of the word `location'.
author Ben Wing <ben@xemacs.org>
date Wed, 03 Feb 2010 08:01:55 -0600
parents 1628e3b9601a
children 053f3c9af8c0
comparison
equal deleted inserted replaced
4914:1628e3b9601a 4921:17362f371cc2
56 #include "bytecode.h" 56 #include "bytecode.h"
57 #include "opaque.h" 57 #include "opaque.h"
58 #include "syntax.h" 58 #include "syntax.h"
59 #include "window.h" 59 #include "window.h"
60 60
61 #define NUM_REMEMBERED_BYTE_OPS 100
62
61 #ifdef NEW_GC 63 #ifdef NEW_GC
62 static Lisp_Object 64 static Lisp_Object
63 make_compiled_function_args (int totalargs) 65 make_compiled_function_args (int totalargs)
64 { 66 {
65 Lisp_Compiled_Function_Args *args; 67 Lisp_Compiled_Function_Args *args;
99 101
100 EXFUN (Ffetch_bytecode, 1); 102 EXFUN (Ffetch_bytecode, 1);
101 103
102 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code; 104 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
103 105
106
104 enum Opcode /* Byte codes */ 107 enum Opcode /* Byte codes */
105 { 108 {
106 Bvarref = 010, 109 #define OPCODE(sym, val) B##sym = val,
107 Bvarset = 020, 110 #include "bytecode-ops.h"
108 Bvarbind = 030,
109 Bcall = 040,
110 Bunbind = 050,
111
112 Bnth = 070,
113 Bsymbolp = 071,
114 Bconsp = 072,
115 Bstringp = 073,
116 Blistp = 074,
117 Bold_eq = 075,
118 Bold_memq = 076,
119 Bnot = 077,
120 Bcar = 0100,
121 Bcdr = 0101,
122 Bcons = 0102,
123 Blist1 = 0103,
124 Blist2 = 0104,
125 Blist3 = 0105,
126 Blist4 = 0106,
127 Blength = 0107,
128 Baref = 0110,
129 Baset = 0111,
130 Bsymbol_value = 0112,
131 Bsymbol_function = 0113,
132 Bset = 0114,
133 Bfset = 0115,
134 Bget = 0116,
135 Bsubstring = 0117,
136 Bconcat2 = 0120,
137 Bconcat3 = 0121,
138 Bconcat4 = 0122,
139 Bsub1 = 0123,
140 Badd1 = 0124,
141 Beqlsign = 0125,
142 Bgtr = 0126,
143 Blss = 0127,
144 Bleq = 0130,
145 Bgeq = 0131,
146 Bdiff = 0132,
147 Bnegate = 0133,
148 Bplus = 0134,
149 Bmax = 0135,
150 Bmin = 0136,
151 Bmult = 0137,
152
153 Bpoint = 0140,
154 Beq = 0141, /* was Bmark,
155 but no longer generated as of v18 */
156 Bgoto_char = 0142,
157 Binsert = 0143,
158 Bpoint_max = 0144,
159 Bpoint_min = 0145,
160 Bchar_after = 0146,
161 Bfollowing_char = 0147,
162 Bpreceding_char = 0150,
163 Bcurrent_column = 0151,
164 Bindent_to = 0152,
165 Bequal = 0153, /* was Bscan_buffer,
166 but no longer generated as of v18 */
167 Beolp = 0154,
168 Beobp = 0155,
169 Bbolp = 0156,
170 Bbobp = 0157,
171 Bcurrent_buffer = 0160,
172 Bset_buffer = 0161,
173 Bsave_current_buffer = 0162, /* was Bread_char,
174 but no longer generated as of v19 */
175 Bmemq = 0163, /* was Bset_mark,
176 but no longer generated as of v18 */
177 Binteractive_p = 0164, /* Needed since interactive-p takes
178 unevalled args */
179 Bforward_char = 0165,
180 Bforward_word = 0166,
181 Bskip_chars_forward = 0167,
182 Bskip_chars_backward = 0170,
183 Bforward_line = 0171,
184 Bchar_syntax = 0172,
185 Bbuffer_substring = 0173,
186 Bdelete_region = 0174,
187 Bnarrow_to_region = 0175,
188 Bwiden = 0176,
189 Bend_of_line = 0177,
190
191 Bconstant2 = 0201,
192 Bgoto = 0202,
193 Bgotoifnil = 0203,
194 Bgotoifnonnil = 0204,
195 Bgotoifnilelsepop = 0205,
196 Bgotoifnonnilelsepop = 0206,
197 Breturn = 0207,
198 Bdiscard = 0210,
199 Bdup = 0211,
200
201 Bsave_excursion = 0212,
202 Bsave_window_excursion= 0213,
203 Bsave_restriction = 0214,
204 Bcatch = 0215,
205
206 Bunwind_protect = 0216,
207 Bcondition_case = 0217,
208 Btemp_output_buffer_setup = 0220,
209 Btemp_output_buffer_show = 0221,
210
211 Bunbind_all = 0222,
212
213 Bset_marker = 0223,
214 Bmatch_beginning = 0224,
215 Bmatch_end = 0225,
216 Bupcase = 0226,
217 Bdowncase = 0227,
218
219 Bstring_equal = 0230,
220 Bstring_lessp = 0231,
221 Bold_equal = 0232,
222 Bnthcdr = 0233,
223 Belt = 0234,
224 Bold_member = 0235,
225 Bold_assq = 0236,
226 Bnreverse = 0237,
227 Bsetcar = 0240,
228 Bsetcdr = 0241,
229 Bcar_safe = 0242,
230 Bcdr_safe = 0243,
231 Bnconc = 0244,
232 Bquo = 0245,
233 Brem = 0246,
234 Bnumberp = 0247,
235 Bfixnump = 0250, /* Was Bintegerp. */
236
237 BRgoto = 0252,
238 BRgotoifnil = 0253,
239 BRgotoifnonnil = 0254,
240 BRgotoifnilelsepop = 0255,
241 BRgotoifnonnilelsepop = 0256,
242
243 BlistN = 0257,
244 BconcatN = 0260,
245 BinsertN = 0261,
246
247 Bbind_multiple_value_limits = 0262, /* New in 21.5. */
248 Bmultiple_value_list_internal = 0263, /* New in 21.5. */
249 Bmultiple_value_call = 0264, /* New in 21.5. */
250 Bthrow = 0265, /* New in 21.5. */
251
252 Bmember = 0266, /* new in v20 */
253 Bassq = 0267, /* new in v20 */
254
255 Bconstant = 0300
256 }; 111 };
257 typedef enum Opcode Opcode; 112 typedef enum Opcode Opcode;
258
259 113
260 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr, 114 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
115 #ifdef ERROR_CHECK_BYTE_CODE
116 Lisp_Object *stack_beg,
117 Lisp_Object *stack_end,
118 #endif /* ERROR_CHECK_BYTE_CODE */
261 const Opbyte *program_ptr, 119 const Opbyte *program_ptr,
262 Opcode opcode); 120 Opcode opcode);
263 121
264 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram. 122 #ifndef ERROR_CHECK_BYTE_CODE
265 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */ 123
266 /* #define BYTE_CODE_METER */ 124 # define bytecode_assert(x) disabled_assert (x)
125 # define bytecode_assert_with_message(x, msg) disabled_assert(x)
126 # define bytecode_abort_with_message(msg) abort_with_message (msg)
127
128 #else /* ERROR_CHECK_BYTE_CODE */
129
130 # define bytecode_assert(x) \
131 ((x) ? (void) 0 : assert_failed_with_remembered_ops (__FILE__, __LINE__, #x))
132 # define bytecode_assert_with_message(x, msg) \
133 ((x) ? (void) 0 : assert_failed_with_remembered_ops (__FILE__, __LINE__, msg))
134 # define bytecode_abort_with_message(msg) \
135 assert_failed_with_remembered_ops (__FILE__, __LINE__, msg)
136
137 /* Table mapping opcodes to their names. This handles opcodes like
138 Bvarref+7, but it doesn't list any of the Bconstant+N opcodes; those
139 are handled specially. */
140 Ascbyte *opcode_name_table[256];
141
142 /* Circular queue remembering the most recent operations. */
143 Opcode remembered_ops[NUM_REMEMBERED_BYTE_OPS];
144 int remembered_op_next_pos, num_remembered;
145
146 static void
147 remember_operation (Opcode op)
148 {
149 remembered_ops[remembered_op_next_pos] = op;
150 remembered_op_next_pos =
151 (remembered_op_next_pos + 1) % NUM_REMEMBERED_BYTE_OPS;
152 if (num_remembered < NUM_REMEMBERED_BYTE_OPS)
153 num_remembered++;
154 }
155
156 static void
157 assert_failed_with_remembered_ops (const Ascbyte *file, int line,
158 Ascbyte *msg_to_abort_with)
159 {
160 Ascbyte *msg =
161 alloca_array (Ascbyte,
162 NUM_REMEMBERED_BYTE_OPS*50 + strlen (msg_to_abort_with));
163 int i;
164
165 if (msg_to_abort_with)
166 strcpy (msg, msg_to_abort_with);
167 strcat (msg, "\n\nRecent bytecodes, oldest first:\n\n");
168
169 for (i = 0; i < num_remembered; i++)
170 {
171 Ascbyte msg2[50];
172 int pos;
173 Opcode op;
174
175 sprintf (msg2, "%5d: ", i - num_remembered + 1);
176 strcat (msg, msg2);
177 pos = (remembered_op_next_pos + NUM_REMEMBERED_BYTE_OPS +
178 i - num_remembered) % NUM_REMEMBERED_BYTE_OPS;
179 op = remembered_ops[pos];
180 if (op >= Bconstant)
181 {
182 sprintf (msg2, "constant+%d", op - Bconstant);
183 strcat (msg, msg2);
184 }
185 else
186 {
187 Ascbyte *opname = opcode_name_table[op];
188 if (!opname)
189 {
190 stderr_out ("Internal error! NULL pointer in opcode_name_table, opcode %d\n", op);
191 strcat (msg, "NULL");
192 }
193 else
194 strcat (msg, opname);
195 }
196 sprintf (msg2, " (%d)\n", op);
197 strcat (msg, msg2);
198 }
199
200 assert_failed (file, line, msg);
201 }
202
203 #endif /* ERROR_CHECK_BYTE_CODE */
267 204
268 205
269 #ifdef BYTE_CODE_METER 206 #ifdef BYTE_CODE_METER
270 207
271 Lisp_Object Vbyte_code_meter, Qbyte_code_meter; 208 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
617 } 554 }
618 #endif /* WITH_NUMBER_TYPES */ 555 #endif /* WITH_NUMBER_TYPES */
619 } 556 }
620 557
621 558
559
560 /*********************** The instruction array *********************/
561
562 /* Check that there are at least LEN elements left in the end of the
563 instruction array before fetching them. Note that we allow for
564 PROGRAM_PTR == PROGRAM_END after the fetch -- that means there are
565 no more elements to fetch next time around, but we might exit before
566 next time comes.
567
568 When checking the destination if jumps, however, we don't allow
569 PROGRAM_PTR to equal PROGRAM_END, since we will always be fetching
570 another instruction after the jump. */
571
572 #define CHECK_OPCODE_SPACE(len) \
573 bytecode_assert (program_ptr + len <= program_end)
574
622 /* Read next uint8 from the instruction stream. */ 575 /* Read next uint8 from the instruction stream. */
623 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++) 576 #define READ_UINT_1 \
577 (CHECK_OPCODE_SPACE (1), (unsigned int) (unsigned char) *program_ptr++)
624 578
625 /* Read next uint16 from the instruction stream. */ 579 /* Read next uint16 from the instruction stream. */
626 #define READ_UINT_2 \ 580 #define READ_UINT_2 \
627 (program_ptr += 2, \ 581 (CHECK_OPCODE_SPACE (2), \
582 program_ptr += 2, \
628 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \ 583 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \
629 ((unsigned int) (unsigned char) program_ptr[-2]))) 584 ((unsigned int) (unsigned char) program_ptr[-2])))
630 585
631 /* Read next int8 from the instruction stream. */ 586 /* Read next int8 from the instruction stream. */
632 #define READ_INT_1 ((int) (signed char) *program_ptr++) 587 #define READ_INT_1 \
588 (CHECK_OPCODE_SPACE (1), (int) (signed char) *program_ptr++)
633 589
634 /* Read next int16 from the instruction stream. */ 590 /* Read next int16 from the instruction stream. */
635 #define READ_INT_2 \ 591 #define READ_INT_2 \
636 (program_ptr += 2, \ 592 (CHECK_OPCODE_SPACE (2), \
593 program_ptr += 2, \
637 (((int) ( signed char) program_ptr[-1]) * 256 + \ 594 (((int) ( signed char) program_ptr[-1]) * 256 + \
638 ((int) (unsigned char) program_ptr[-2]))) 595 ((int) (unsigned char) program_ptr[-2])))
639 596
640 /* Read next int8 from instruction stream; don't advance program_pointer */ 597 /* Read next int8 from instruction stream; don't advance program_pointer */
641 #define PEEK_INT_1 ((int) (signed char) program_ptr[0]) 598 #define PEEK_INT_1 \
599 (CHECK_OPCODE_SPACE (1), (int) (signed char) program_ptr[0])
642 600
643 /* Read next int16 from instruction stream; don't advance program_pointer */ 601 /* Read next int16 from instruction stream; don't advance program_pointer */
644 #define PEEK_INT_2 \ 602 #define PEEK_INT_2 \
645 ((((int) ( signed char) program_ptr[1]) * 256) | \ 603 (CHECK_OPCODE_SPACE (2), \
604 (((int) ( signed char) program_ptr[1]) * 256) | \
646 ((int) (unsigned char) program_ptr[0])) 605 ((int) (unsigned char) program_ptr[0]))
647 606
648 /* Do relative jumps from the current location. 607 /* Do relative jumps from the current location.
649 We only do a QUIT if we jump backwards, for efficiency. 608 We only do a QUIT if we jump backwards, for efficiency.
650 No infloops without backward jumps! */ 609 No infloops without backward jumps! */
651 #define JUMP_RELATIVE(jump) do { \ 610 #define JUMP_RELATIVE(jump) do { \
652 int JR_jump = (jump); \ 611 int _JR_jump = (jump); \
653 if (JR_jump < 0) QUIT; \ 612 if (_JR_jump < 0) QUIT; \
654 program_ptr += JR_jump; \ 613 /* Check that where we're going to is in range. Note that we don't use \
614 CHECK_OPCODE_SPACE() -- that only checks the end, and it allows \
615 program_ptr == program_end, which we don't allow. */ \
616 bytecode_assert (program_ptr + _JR_jump >= program && \
617 program_ptr + _JR_jump < program_end); \
618 program_ptr += _JR_jump; \
655 } while (0) 619 } while (0)
656 620
657 #define JUMP JUMP_RELATIVE (PEEK_INT_2) 621 #define JUMP JUMP_RELATIVE (PEEK_INT_2)
658 #define JUMPR JUMP_RELATIVE (PEEK_INT_1) 622 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
659 623
660 #define JUMP_NEXT ((void) (program_ptr += 2)) 624 #define JUMP_NEXT (CHECK_OPCODE_SPACE (2), (void) (program_ptr += 2))
661 #define JUMPR_NEXT ((void) (program_ptr += 1)) 625 #define JUMPR_NEXT (CHECK_OPCODE_SPACE (1), (void) (program_ptr += 1))
626
627 /*********************** The stack array *********************/
628
629 /* NOTE: The stack array doesn't work quite like you'd expect.
630
631 STACK_PTR points to the value on the top of the stack. Popping a value
632 fetches the value from the STACK_PTR and then decrements it. Pushing a
633 value first increments it, then writes the new value. STACK_PTR -
634 STACK_BEG is the number of elements on the stack.
635
636 This means that when STACK_PTR == STACK_BEG, the stack is empty, and
637 the space at STACK_BEG is never written to -- the first push will write
638 into the space directly after STACK_BEG. This is why the call to
639 alloca_array() below has a count of `stack_depth + 1', and why
640 we GCPRO1 (stack_ptr[1]) -- the value at stack_ptr[0] is unused and
641 uninitialized.
642
643 Also, STACK_END actually points to the last usable storage location,
644 and does not point past the end, like you'd expect. */
645
646 #define CHECK_STACKPTR_OFFSET(len) \
647 bytecode_assert (stack_ptr + (len) >= stack_beg && \
648 stack_ptr + (len) <= stack_end)
662 649
663 /* Push x onto the execution stack. */ 650 /* Push x onto the execution stack. */
664 #define PUSH(x) (*++stack_ptr = (x)) 651 #define PUSH(x) (CHECK_STACKPTR_OFFSET (1), *++stack_ptr = (x))
665 652
666 /* Pop a value, which may be multiple, off the execution stack. */ 653 /* Pop a value, which may be multiple, off the execution stack. */
667 #define POP_WITH_MULTIPLE_VALUES (*stack_ptr--) 654 #define POP_WITH_MULTIPLE_VALUES (CHECK_STACKPTR_OFFSET (-1), *stack_ptr--)
668 655
669 /* Pop a value off the execution stack, treating multiple values as single. */ 656 /* Pop a value off the execution stack, treating multiple values as single. */
670 #define POP (IGNORE_MULTIPLE_VALUES (POP_WITH_MULTIPLE_VALUES)) 657 #define POP (IGNORE_MULTIPLE_VALUES (POP_WITH_MULTIPLE_VALUES))
671 658
672 #define DISCARD_PRESERVING_MULTIPLE_VALUES(n) (stack_ptr -= (n)) 659 /* ..._UNSAFE() means it evaluates its argument more than once. */
660 #define DISCARD_PRESERVING_MULTIPLE_VALUES_UNSAFE(n) \
661 (CHECK_STACKPTR_OFFSET (-(n)), stack_ptr -= (n))
673 662
674 /* Discard n values from the execution stack. */ 663 /* Discard n values from the execution stack. */
675 #define DISCARD(n) do { \ 664 #define DISCARD(n) do { \
665 int _discard_n = (n); \
676 if (1 != multiple_value_current_limit) \ 666 if (1 != multiple_value_current_limit) \
677 { \ 667 { \
678 int i, en = n; \ 668 int i; \
679 for (i = 0; i < en; i++) \ 669 for (i = 0; i < _discard_n; i++) \
680 { \ 670 { \
671 CHECK_STACKPTR_OFFSET (-1); \
681 *stack_ptr = ignore_multiple_values (*stack_ptr); \ 672 *stack_ptr = ignore_multiple_values (*stack_ptr); \
682 stack_ptr--; \ 673 stack_ptr--; \
683 } \ 674 } \
684 } \ 675 } \
685 else \ 676 else \
686 { \ 677 { \
687 stack_ptr -= (n); \ 678 CHECK_STACKPTR_OFFSET (-_discard_n); \
679 stack_ptr -= _discard_n; \
688 } \ 680 } \
689 } while (0) 681 } while (0)
690 682
691 /* Get the value, which may be multiple, at the top of the execution stack; 683 /* Get the value, which may be multiple, at the top of the execution stack;
692 and leave it there. */ 684 and leave it there. */
702 694
703 695
704 696
705 /* See comment before the big switch in execute_optimized_program(). */ 697 /* See comment before the big switch in execute_optimized_program(). */
706 #define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg) 698 #define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg)
699
707 700
708 /* The actual interpreter for byte code. 701 /* The actual interpreter for byte code.
709 This function has been seriously optimized for performance. 702 This function has been seriously optimized for performance.
710 Don't change the constructs unless you are willing to do 703 Don't change the constructs unless you are willing to do
711 real benchmarking and profiling work -- martin */ 704 real benchmarking and profiling work -- martin */
712 705
713 706
714 Lisp_Object 707 Lisp_Object
715 execute_optimized_program (const Opbyte *program, 708 execute_optimized_program (const Opbyte *program,
709 #ifdef ERROR_CHECK_BYTE_CODE
710 Elemcount program_length,
711 #endif
716 int stack_depth, 712 int stack_depth,
717 Lisp_Object *constants_data) 713 Lisp_Object *constants_data)
718 { 714 {
719 /* This function can GC */ 715 /* This function can GC */
720 REGISTER const Opbyte *program_ptr = (Opbyte *) program; 716 REGISTER const Opbyte *program_ptr = (Opbyte *) program;
717 #ifdef ERROR_CHECK_BYTE_CODE
718 const Opbyte *program_end = program_ptr + program_length;
719 #endif
720 /* See comment above explaining the `+ 1' */
721 Lisp_Object *stack_beg = alloca_array (Lisp_Object, stack_depth + 1); 721 Lisp_Object *stack_beg = alloca_array (Lisp_Object, stack_depth + 1);
722 REGISTER Lisp_Object *stack_ptr = stack_beg; 722 REGISTER Lisp_Object *stack_ptr = stack_beg;
723 int speccount = specpdl_depth (); 723 int speccount = specpdl_depth ();
724 struct gcpro gcpro1; 724 struct gcpro gcpro1;
725 725
757 loses its reference and is effectively UNGCPROed, and the new object is 757 loses its reference and is effectively UNGCPROed, and the new object is
758 automatically GCPROed as long as nvars is correct. Only when we 758 automatically GCPROed as long as nvars is correct. Only when we
759 return from the interpreter do we need to finalize the struct gcpro 759 return from the interpreter do we need to finalize the struct gcpro
760 itself, and that's done at case Breturn. 760 itself, and that's done at case Breturn.
761 */ 761 */
762
763 /* See comment above explaining the `[1]' */
762 GCPRO1 (stack_ptr[1]); 764 GCPRO1 (stack_ptr[1]);
763 765
764 while (1) 766 while (1)
765 { 767 {
766 REGISTER Opcode opcode = (Opcode) READ_UINT_1; 768 REGISTER Opcode opcode = (Opcode) READ_UINT_1;
767 769
770 #ifdef ERROR_CHECK_BYTE_CODE
771 remember_operation (opcode);
772 #endif
773
768 GCPRO_STACK; /* Get nvars right before maybe signaling. */ 774 GCPRO_STACK; /* Get nvars right before maybe signaling. */
775 /* #### NOTE: This code should probably never get triggered, since we
776 now catch the problems earlier, farther down, before we ever set
777 a bad value for STACK_PTR. */
769 #ifdef ERROR_CHECK_BYTE_CODE 778 #ifdef ERROR_CHECK_BYTE_CODE
770 if (stack_ptr > stack_end) 779 if (stack_ptr > stack_end)
771 stack_overflow ("byte code stack overflow", Qunbound); 780 stack_overflow ("byte code stack overflow", Qunbound);
772 if (stack_ptr < stack_beg) 781 if (stack_ptr < stack_beg)
773 stack_overflow ("byte code stack underflow", Qunbound); 782 stack_overflow ("byte code stack underflow", Qunbound);
788 PUSH (constants_data[opcode - Bconstant]); 797 PUSH (constants_data[opcode - Bconstant]);
789 else 798 else
790 { 799 {
791 /* We're not sure what these do, so better safe than sorry. */ 800 /* We're not sure what these do, so better safe than sorry. */
792 /* GCPRO_STACK; */ 801 /* GCPRO_STACK; */
793 stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode); 802 stack_ptr = execute_rare_opcode (stack_ptr,
803 #ifdef ERROR_CHECK_BYTE_CODE
804 stack_beg,
805 stack_end,
806 #endif /* ERROR_CHECK_BYTE_CODE */
807 program_ptr, opcode);
808 CHECK_STACKPTR_OFFSET (0);
794 } 809 }
795 break; 810 break;
796 811
797 case Bvarref: 812 case Bvarref:
798 case Bvarref+1: 813 case Bvarref+1:
1436 rarely executed code, to minimize cache misses. 1451 rarely executed code, to minimize cache misses.
1437 1452
1438 Don't make this function static, since then the compiler might inline it. */ 1453 Don't make this function static, since then the compiler might inline it. */
1439 Lisp_Object * 1454 Lisp_Object *
1440 execute_rare_opcode (Lisp_Object *stack_ptr, 1455 execute_rare_opcode (Lisp_Object *stack_ptr,
1456 #ifdef ERROR_CHECK_BYTE_CODE
1457 Lisp_Object *stack_beg,
1458 Lisp_Object *stack_end,
1459 #endif /* ERROR_CHECK_BYTE_CODE */
1441 const Opbyte *UNUSED (program_ptr), 1460 const Opbyte *UNUSED (program_ptr),
1442 Opcode opcode) 1461 Opcode opcode)
1443 { 1462 {
1444 REGISTER int n; 1463 REGISTER int n;
1445 1464
1446 switch (opcode) 1465 switch (opcode)
1447 { 1466 {
1448 1467
1449 case Bsave_excursion: 1468 case Bsave_excursion:
1450 record_unwind_protect (save_excursion_restore, 1469 record_unwind_protect (save_excursion_restore,
1451 save_excursion_save ()); 1470 save_excursion_save ());
1452 break; 1471 break;
1453 1472
1712 } 1731 }
1713 1732
1714 case Bmultiple_value_call: 1733 case Bmultiple_value_call:
1715 { 1734 {
1716 n = XINT (POP); 1735 n = XINT (POP);
1717 DISCARD_PRESERVING_MULTIPLE_VALUES (n - 1); 1736 DISCARD_PRESERVING_MULTIPLE_VALUES_UNSAFE (n - 1);
1718 /* Discard multiple values for the first (function) argument: */ 1737 /* Discard multiple values for the first (function) argument: */
1719 TOP_LVALUE = TOP; 1738 TOP_LVALUE = TOP;
1720 TOP_LVALUE = multiple_value_call (n, TOP_ADDRESS); 1739 TOP_LVALUE = multiple_value_call (n, TOP_ADDRESS);
1721 break; 1740 break;
1722 } 1741 }
1723 1742
1724 case Bmultiple_value_list_internal: 1743 case Bmultiple_value_list_internal:
1725 { 1744 {
1726 DISCARD_PRESERVING_MULTIPLE_VALUES (3); 1745 DISCARD_PRESERVING_MULTIPLE_VALUES_UNSAFE (3);
1727 TOP_LVALUE = multiple_value_list_internal (4, TOP_ADDRESS); 1746 TOP_LVALUE = multiple_value_list_internal (4, TOP_ADDRESS);
1728 break; 1747 break;
1729 } 1748 }
1730 1749
1731 case Bthrow: 1750 case Bthrow:
1739 1758
1740 default: 1759 default:
1741 { 1760 {
1742 Ascbyte msg[100]; 1761 Ascbyte msg[100];
1743 sprintf (msg, "Unknown opcode %d", opcode); 1762 sprintf (msg, "Unknown opcode %d", opcode);
1744 abort_with_msg (msg); 1763 bytecode_abort_with_message (msg);
1745 } 1764 }
1746 break; 1765 break;
1747 } 1766 }
1748 return stack_ptr; 1767 return stack_ptr;
1749 } 1768 }
1864 optimize_byte_code (/* in */ 1883 optimize_byte_code (/* in */
1865 Lisp_Object instructions, 1884 Lisp_Object instructions,
1866 Lisp_Object constants, 1885 Lisp_Object constants,
1867 /* out */ 1886 /* out */
1868 Opbyte * const program, 1887 Opbyte * const program,
1869 int * const program_length, 1888 Elemcount * const program_length,
1870 int * const varbind_count) 1889 Elemcount * const varbind_count)
1871 { 1890 {
1872 Bytecount instructions_length = XSTRING_LENGTH (instructions); 1891 Bytecount instructions_length = XSTRING_LENGTH (instructions);
1873 Elemcount comfy_size = (Elemcount) (2 * instructions_length); 1892 Elemcount comfy_size = (Elemcount) (2 * instructions_length);
1874 1893
1875 int * const icounts = alloca_array (int, comfy_size); 1894 int * const icounts = alloca_array (int, comfy_size);
2129 instructions slot of the Compiled_Function object. */ 2148 instructions slot of the Compiled_Function object. */
2130 void 2149 void
2131 optimize_compiled_function (Lisp_Object compiled_function) 2150 optimize_compiled_function (Lisp_Object compiled_function)
2132 { 2151 {
2133 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function); 2152 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
2134 int program_length; 2153 Elemcount program_length;
2135 int varbind_count; 2154 Elemcount varbind_count;
2136 Opbyte *program; 2155 Opbyte *program;
2137 2156
2138 { 2157 {
2139 int minargs = 0, maxargs = 0, totalargs = 0; 2158 int minargs = 0, maxargs = 0, totalargs = 0;
2140 int optional_p = 0, rest_p = 0, i = 0; 2159 int optional_p = 0, rest_p = 0, i = 0;
2702 If STACK-DEPTH is incorrect, Emacs may crash. 2721 If STACK-DEPTH is incorrect, Emacs may crash.
2703 */ 2722 */
2704 (instructions, constants, stack_depth)) 2723 (instructions, constants, stack_depth))
2705 { 2724 {
2706 /* This function can GC */ 2725 /* This function can GC */
2707 int varbind_count; 2726 Elemcount varbind_count;
2708 int program_length; 2727 Elemcount program_length;
2709 Opbyte *program; 2728 Opbyte *program;
2710 2729
2711 CHECK_STRING (instructions); 2730 CHECK_STRING (instructions);
2712 CHECK_VECTOR (constants); 2731 CHECK_VECTOR (constants);
2713 CHECK_NATNUM (stack_depth); 2732 CHECK_NATNUM (stack_depth);
2718 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions)); 2737 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
2719 optimize_byte_code (instructions, constants, program, 2738 optimize_byte_code (instructions, constants, program,
2720 &program_length, &varbind_count); 2739 &program_length, &varbind_count);
2721 SPECPDL_RESERVE (varbind_count); 2740 SPECPDL_RESERVE (varbind_count);
2722 return execute_optimized_program (program, 2741 return execute_optimized_program (program,
2742 #ifdef ERROR_CHECK_BYTE_CODE
2743 program_length,
2744 #endif
2723 XINT (stack_depth), 2745 XINT (stack_depth),
2724 XVECTOR_DATA (constants)); 2746 XVECTOR_DATA (constants));
2725 } 2747 }
2726 2748
2727 2749
2760 2782
2761 void 2783 void
2762 vars_of_bytecode (void) 2784 vars_of_bytecode (void)
2763 { 2785 {
2764 #ifdef BYTE_CODE_METER 2786 #ifdef BYTE_CODE_METER
2765
2766 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /* 2787 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
2767 A vector of vectors which holds a histogram of byte code usage. 2788 A vector of vectors which holds a histogram of byte code usage.
2768 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte 2789 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2769 opcode CODE has been executed. 2790 opcode CODE has been executed.
2770 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0, 2791 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2785 while (i--) 2806 while (i--)
2786 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero); 2807 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
2787 } 2808 }
2788 #endif /* BYTE_CODE_METER */ 2809 #endif /* BYTE_CODE_METER */
2789 } 2810 }
2811
2812 #ifdef ERROR_CHECK_BYTE_CODE
2813
2814 /* Initialize the opcodes in the table that correspond to a base opcode
2815 plus an offset (except for Bconstant). */
2816
2817 static void
2818 init_opcode_table_multi_op (Opcode op)
2819 {
2820 Ascbyte *basename = opcode_name_table[op];
2821 Ascbyte temp[300];
2822 int i;
2823
2824 for (i = 1; i < 7; i++)
2825 {
2826 assert (!opcode_name_table[op + i]);
2827 sprintf (temp, "%s+%d", basename, i);
2828 opcode_name_table[op + i] = xstrdup (temp);
2829 }
2830 }
2831
2832 #endif /* ERROR_CHECK_BYTE_CODE */
2833
2834 void
2835 reinit_vars_of_bytecode (void)
2836 {
2837 #ifdef ERROR_CHECK_BYTE_CODE
2838 int i;
2839
2840 #define OPCODE(sym, val) opcode_name_table[val] = xstrdup (#sym);
2841 #include "bytecode-ops.h"
2842
2843 for (i = 0; i < countof (opcode_name_table); i++)
2844 {
2845 int j;
2846 Ascbyte *name = opcode_name_table[i];
2847 if (name)
2848 {
2849 Bytecount len = strlen (name);
2850 /* Prettify the name by converting underscores to hyphens, similar
2851 to what happens with DEFSYMBOL. */
2852 for (j = 0; j < len; j++)
2853 if (name[j] == '_')
2854 name[j] = '-';
2855 }
2856 }
2857
2858 init_opcode_table_multi_op (Bvarref);
2859 init_opcode_table_multi_op (Bvarset);
2860 init_opcode_table_multi_op (Bvarbind);
2861 init_opcode_table_multi_op (Bcall);
2862 init_opcode_table_multi_op (Bunbind);
2863 #endif /* ERROR_CHECK_BYTE_CODE */
2864 }