1 /* Execution of byte code produced by bytecomp.el.
2 Implementation of compiled-function objects.
3 Copyright (C) 1992, 1993 Free Software Foundation, Inc.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Mule 2.0, FSF 19.30. */
24 /* This file has been Mule-ized. */
31 hacked on by jwz@netscape.com 1991-06
32 o added a compile-time switch to turn on simple sanity checking;
33 o put back the obsolete byte-codes for error-detection;
34 o added a new instruction, unbind_all, which I will use for
35 tail-recursion elimination;
36 o made temp_output_buffer_show be called with the right number
38 o made the new bytecodes be called with args in the right order;
39 o added metering support.
42 o added relative jump instructions;
43 o all conditionals now only do QUIT if they jump.
45 Ben Wing: some changes for Mule, 1995-06.
47 Martin Buchholz: performance hacking, 1998-09.
48 See Internals Manual, Evaluation.
53 #include "backtrace.h"
62 EXFUN (Ffetch_bytecode, 1);
64 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
66 enum Opcode /* Byte codes */
93 Bsymbol_function = 0113,
116 Beq = 0141, /* was Bmark,
117 but no longer generated as of v18 */
123 Bfollowing_char = 0147,
124 Bpreceding_char = 0150,
125 Bcurrent_column = 0151,
127 Bequal = 0153, /* was Bscan_buffer,
128 but no longer generated as of v18 */
133 Bcurrent_buffer = 0160,
135 Bsave_current_buffer = 0162, /* was Bread_char,
136 but no longer generated as of v19 */
137 Bmemq = 0163, /* was Bset_mark,
138 but no longer generated as of v18 */
139 Binteractive_p = 0164, /* Needed since interactive-p takes
141 Bforward_char = 0165,
142 Bforward_word = 0166,
143 Bskip_chars_forward = 0167,
144 Bskip_chars_backward = 0170,
145 Bforward_line = 0171,
147 Bbuffer_substring = 0173,
148 Bdelete_region = 0174,
149 Bnarrow_to_region = 0175,
156 Bgotoifnonnil = 0204,
157 Bgotoifnilelsepop = 0205,
158 Bgotoifnonnilelsepop = 0206,
163 Bsave_excursion = 0212,
164 Bsave_window_excursion= 0213,
165 Bsave_restriction = 0214,
168 Bunwind_protect = 0216,
169 Bcondition_case = 0217,
170 Btemp_output_buffer_setup = 0220,
171 Btemp_output_buffer_show = 0221,
176 Bmatch_beginning = 0224,
181 Bstring_equal = 0230,
182 Bstring_lessp = 0231,
201 BRgotoifnonnil = 0254,
202 BRgotoifnilelsepop = 0255,
203 BRgotoifnonnilelsepop = 0256,
208 Bmember = 0266, /* new in v20 */
209 Bassq = 0267, /* new in v20 */
213 typedef enum Opcode Opcode;
214 typedef unsigned char Opbyte;
217 static void invalid_byte_code_error (char *error_message, ...);
219 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
220 CONST Opbyte *program_ptr,
223 static Lisp_Object execute_optimized_program (CONST Opbyte *program,
225 Lisp_Object *constants_data);
227 extern Lisp_Object Qand_rest, Qand_optional;
229 /* Define ERROR_CHECK_BYTE_CODE to enable some minor sanity checking.
230 Useful for debugging the byte compiler. */
232 #define ERROR_CHECK_BYTE_CODE
235 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
236 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
237 /* #define BYTE_CODE_METER */
240 #ifdef BYTE_CODE_METER
242 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
243 int byte_metering_on;
245 #define METER_2(code1, code2) \
246 XINT (XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[(code1)])[(code2)])
248 #define METER_1(code) METER_2 (0, (code))
250 #define METER_CODE(last_code, this_code) do { \
251 if (byte_metering_on) \
253 if (METER_1 (this_code) != ((1<<VALBITS)-1)) \
254 METER_1 (this_code)++; \
256 && METER_2 (last_code, this_code) != ((1<<VALBITS)-1)) \
257 METER_2 (last_code, this_code)++; \
261 #endif /* BYTE_CODE_METER */
265 bytecode_negate (Lisp_Object obj)
269 #ifdef LISP_FLOAT_TYPE
270 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
272 if (CHARP (obj)) return make_int (- ((int) XCHAR (obj)));
273 if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));
274 if (INTP (obj)) return make_int (- XINT (obj));
276 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
281 bytecode_nreverse (Lisp_Object list)
283 REGISTER Lisp_Object prev = Qnil;
284 REGISTER Lisp_Object tail = list;
288 REGISTER Lisp_Object next;
299 /* We have our own two-argument versions of various arithmetic ops.
300 Only two-argument arithmetic operations have their own byte codes. */
302 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2)
306 #ifdef LISP_FLOAT_TYPE
310 if (INTP (obj1)) ival1 = XINT (obj1);
311 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
312 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
313 else goto arithcompare_float;
315 if (INTP (obj2)) ival2 = XINT (obj2);
316 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
317 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
318 else goto arithcompare_float;
320 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
328 if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1);
329 else if (INTP (obj1)) dval1 = (double) XINT (obj1);
330 else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1);
331 else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1);
334 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
338 if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2);
339 else if (INTP (obj2)) dval2 = (double) XINT (obj2);
340 else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2);
341 else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2);
344 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
348 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
350 #else /* !LISP_FLOAT_TYPE */
354 if (INTP (obj1)) ival1 = XINT (obj1);
355 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
356 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
359 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
363 if (INTP (obj2)) ival2 = XINT (obj2);
364 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
365 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
368 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
372 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
374 #endif /* !LISP_FLOAT_TYPE */
378 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
380 #ifdef LISP_FLOAT_TYPE
388 if (INTP (obj1)) ival1 = XINT (obj1);
389 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
390 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
391 else if (FLOATP (obj1)) ival1 = 0, float_p = 1;
394 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
398 if (INTP (obj2)) ival2 = XINT (obj2);
399 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
400 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
401 else if (FLOATP (obj2)) ival2 = 0, float_p = 1;
404 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
412 case Bplus: ival1 += ival2; break;
413 case Bdiff: ival1 -= ival2; break;
414 case Bmult: ival1 *= ival2; break;
416 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
419 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
420 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
422 return make_int (ival1);
426 double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1;
427 double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2;
430 case Bplus: dval1 += dval2; break;
431 case Bdiff: dval1 -= dval2; break;
432 case Bmult: dval1 *= dval2; break;
434 if (dval2 == 0) Fsignal (Qarith_error, Qnil);
437 case Bmax: if (dval1 < dval2) dval1 = dval2; break;
438 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
440 return make_float (dval1);
442 #else /* !LISP_FLOAT_TYPE */
447 if (INTP (obj1)) ival1 = XINT (obj1);
448 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
449 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
452 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
456 if (INTP (obj2)) ival2 = XINT (obj2);
457 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
458 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
461 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
467 case Bplus: ival1 += ival2; break;
468 case Bdiff: ival1 -= ival2; break;
469 case Bmult: ival1 *= ival2; break;
471 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
474 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
475 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
477 return make_int (ival1);
478 #endif /* !LISP_FLOAT_TYPE */
481 /* Apply compiled-function object FUN to the NARGS evaluated arguments
482 in ARGS, and return the result of evaluation. */
484 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[])
486 /* This function can GC */
487 Lisp_Object symbol, tail;
488 int speccount = specpdl_depth();
490 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
493 if (!OPAQUEP (f->instructions))
494 /* Lazily munge the instructions into a more efficient form */
495 optimize_compiled_function (fun);
497 /* optimize_compiled_function() guaranteed that f->specpdl_depth is
498 the required space on the specbinding stack for binding the args
499 and local variables of fun. So just reserve it once. */
500 SPECPDL_RESERVE (f->specpdl_depth);
502 /* Fmake_byte_code() guaranteed that f->arglist is a valid list
503 containing only non-constant symbols. */
504 LIST_LOOP_3 (symbol, f->arglist, tail)
506 if (EQ (symbol, Qand_rest))
509 symbol = XCAR (tail);
510 SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i]));
513 else if (EQ (symbol, Qand_optional))
515 else if (i == nargs && !optional)
516 goto wrong_number_of_arguments;
518 SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil);
522 goto wrong_number_of_arguments;
528 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions),
530 XVECTOR_DATA (f->constants));
532 /* The attempt to optimize this by only unbinding variables failed
533 because using buffer-local variables as function parameters
534 leads to specpdl_ptr->func != 0 */
535 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */
536 UNBIND_TO_GCPRO (speccount, value);
540 wrong_number_of_arguments:
541 return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
545 /* Read next uint8 from the instruction stream. */
546 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
548 /* Read next uint16 from the instruction stream. */
549 #define READ_UINT_2 \
551 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \
552 ((unsigned int) (unsigned char) program_ptr[-2])))
554 /* Read next int8 from the instruction stream. */
555 #define READ_INT_1 ((int) (signed char) *program_ptr++)
557 /* Read next int16 from the instruction stream. */
560 (((int) ( signed char) program_ptr[-1]) * 256 + \
561 ((int) (unsigned char) program_ptr[-2])))
563 /* Read next int8 from instruction stream; don't advance program_pointer */
564 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
566 /* Read next int16 from instruction stream; don't advance program_pointer */
568 ((((int) ( signed char) program_ptr[1]) * 256) | \
569 ((int) (unsigned char) program_ptr[0]))
571 /* Do relative jumps from the current location.
572 We only do a QUIT if we jump backwards, for efficiency.
573 No infloops without backward jumps! */
574 #define JUMP_RELATIVE(jump) do { \
575 int JR_jump = (jump); \
576 if (JR_jump < 0) QUIT; \
577 program_ptr += JR_jump; \
580 #define JUMP JUMP_RELATIVE (PEEK_INT_2)
581 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
583 #define JUMP_NEXT ((void) (program_ptr += 2))
584 #define JUMPR_NEXT ((void) (program_ptr += 1))
586 /* Push x onto the execution stack. */
587 #define PUSH(x) (*++stack_ptr = (x))
589 /* Pop a value off the execution stack. */
590 #define POP (*stack_ptr--)
592 /* Discard n values from the execution stack. */
593 #define DISCARD(n) (stack_ptr -= (n))
595 /* Get the value which is at the top of the execution stack,
597 #define TOP (*stack_ptr)
599 /* The actual interpreter for byte code.
600 This function has been seriously optimized for performance.
601 Don't change the constructs unless you are willing to do
602 real benchmarking and profiling work -- martin */
606 execute_optimized_program (CONST Opbyte *program,
608 Lisp_Object *constants_data)
610 /* This function can GC */
611 REGISTER CONST Opbyte *program_ptr = (Opbyte *) program;
612 REGISTER Lisp_Object *stack_ptr
613 = alloca_array (Lisp_Object, stack_depth + 1);
614 int speccount = specpdl_depth ();
617 #ifdef BYTE_CODE_METER
618 Opcode this_opcode = 0;
622 #ifdef ERROR_CHECK_BYTE_CODE
623 Lisp_Object *stack_beg = stack_ptr;
624 Lisp_Object *stack_end = stack_beg + stack_depth;
627 /* Initialize all the objects on the stack to Qnil,
628 so we can GCPRO the whole stack.
629 The first element of the stack is actually a dummy. */
633 for (i = stack_depth, p = stack_ptr; i--;)
637 GCPRO1 (stack_ptr[1]);
638 gcpro1.nvars = stack_depth;
642 REGISTER Opcode opcode = (Opcode) READ_UINT_1;
643 #ifdef ERROR_CHECK_BYTE_CODE
644 if (stack_ptr > stack_end)
645 invalid_byte_code_error ("byte code stack overflow");
646 if (stack_ptr < stack_beg)
647 invalid_byte_code_error ("byte code stack underflow");
650 #ifdef BYTE_CODE_METER
651 prev_opcode = this_opcode;
652 this_opcode = opcode;
653 METER_CODE (prev_opcode, this_opcode);
661 if (opcode >= Bconstant)
662 PUSH (constants_data[opcode - Bconstant]);
664 stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode);
672 case Bvarref+5: n = opcode - Bvarref; goto do_varref;
673 case Bvarref+7: n = READ_UINT_2; goto do_varref;
674 case Bvarref+6: n = READ_UINT_1; /* most common */
677 Lisp_Object symbol = constants_data[n];
678 Lisp_Object value = XSYMBOL (symbol)->value;
679 if (SYMBOL_VALUE_MAGIC_P (value))
680 value = Fsymbol_value (symbol);
690 case Bvarset+5: n = opcode - Bvarset; goto do_varset;
691 case Bvarset+7: n = READ_UINT_2; goto do_varset;
692 case Bvarset+6: n = READ_UINT_1; /* most common */
695 Lisp_Object symbol = constants_data[n];
696 struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
697 Lisp_Object old_value = symbol_ptr->value;
698 Lisp_Object new_value = POP;
699 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
700 symbol_ptr->value = new_value;
702 Fset (symbol, new_value);
711 case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind;
712 case Bvarbind+7: n = READ_UINT_2; goto do_varbind;
713 case Bvarbind+6: n = READ_UINT_1; /* most common */
716 Lisp_Object symbol = constants_data[n];
717 struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
718 Lisp_Object old_value = symbol_ptr->value;
719 Lisp_Object new_value = POP;
720 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
722 specpdl_ptr->symbol = symbol;
723 specpdl_ptr->old_value = old_value;
724 specpdl_ptr->func = 0;
726 specpdl_depth_counter++;
728 symbol_ptr->value = new_value;
731 specbind_magic (symbol, new_value);
743 n = (opcode < Bcall+6 ? opcode - Bcall :
744 opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2);
746 #ifdef BYTE_CODE_METER
747 if (byte_metering_on && SYMBOLP (TOP))
749 Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
751 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
754 TOP = Ffuncall (n + 1, &TOP);
765 UNBIND_TO (specpdl_depth() -
766 (opcode < Bunbind+6 ? opcode-Bunbind :
767 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
788 case Bgotoifnilelsepop:
798 case Bgotoifnonnilelsepop:
827 case BRgotoifnilelsepop:
837 case BRgotoifnonnilelsepop:
849 #ifdef ERROR_CHECK_BYTE_CODE
850 /* Binds and unbinds are supposed to be compiled balanced. */
851 if (specpdl_depth() != speccount)
852 invalid_byte_code_error ("unbalanced specbinding stack");
862 Lisp_Object arg = TOP;
868 PUSH (constants_data[READ_UINT_2]);
872 TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
876 TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
881 /* To unbind back to the beginning of this frame. Not used yet,
882 but will be needed for tail-recursion elimination. */
883 unbind_to (speccount, Qnil);
888 Lisp_Object arg = POP;
889 TOP = Fcar (Fnthcdr (TOP, arg));
894 TOP = SYMBOLP (TOP) ? Qt : Qnil;
898 TOP = CONSP (TOP) ? Qt : Qnil;
902 TOP = STRINGP (TOP) ? Qt : Qnil;
906 TOP = LISTP (TOP) ? Qt : Qnil;
910 TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
914 TOP = INTP (TOP) ? Qt : Qnil;
919 Lisp_Object arg = POP;
920 TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
925 TOP = NILP (TOP) ? Qt : Qnil;
930 Lisp_Object arg = POP;
931 TOP = Fcons (TOP, arg);
936 TOP = Fcons (TOP, Qnil);
948 n = opcode - (Blist1 - 1);
951 Lisp_Object list = Qnil;
953 list = Fcons (TOP, list);
967 n = opcode - (Bconcat2 - 2);
975 TOP = Fconcat (n, &TOP);
985 Lisp_Object arg2 = POP;
986 Lisp_Object arg1 = POP;
987 TOP = Faset (TOP, arg1, arg2);
992 TOP = Fsymbol_value (TOP);
995 case Bsymbol_function:
996 TOP = Fsymbol_function (TOP);
1001 Lisp_Object arg = POP;
1002 TOP = Fget (TOP, arg, Qnil);
1007 TOP = INTP (TOP) ? make_int (XINT (TOP) - 1) : Fsub1 (TOP);
1011 TOP = INTP (TOP) ? make_int (XINT (TOP) + 1) : Fadd1 (TOP);
1017 Lisp_Object arg = POP;
1018 TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
1024 Lisp_Object arg = POP;
1025 TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
1031 Lisp_Object arg = POP;
1032 TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
1038 Lisp_Object arg = POP;
1039 TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
1045 Lisp_Object arg = POP;
1046 TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
1052 TOP = bytecode_negate (TOP);
1057 TOP = bytecode_nconc2 (&TOP);
1062 Lisp_Object arg2 = POP;
1063 Lisp_Object arg1 = TOP;
1064 TOP = INTP (arg1) && INTP (arg2) ?
1065 make_int (XINT (arg1) + XINT (arg2)) :
1066 bytecode_arithop (arg1, arg2, opcode);
1072 Lisp_Object arg2 = POP;
1073 Lisp_Object arg1 = TOP;
1074 TOP = INTP (arg1) && INTP (arg2) ?
1075 make_int (XINT (arg1) - XINT (arg2)) :
1076 bytecode_arithop (arg1, arg2, opcode);
1085 Lisp_Object arg = POP;
1086 TOP = bytecode_arithop (TOP, arg, opcode);
1091 PUSH (make_int (BUF_PT (current_buffer)));
1095 TOP = Finsert (1, &TOP);
1101 TOP = Finsert (n, &TOP);
1106 Lisp_Object arg = POP;
1107 TOP = Faref (TOP, arg);
1113 Lisp_Object arg = POP;
1114 TOP = Fmemq (TOP, arg);
1121 Lisp_Object arg = POP;
1122 TOP = Fset (TOP, arg);
1128 Lisp_Object arg = POP;
1129 TOP = Fequal (TOP, arg);
1135 Lisp_Object arg = POP;
1136 TOP = Fnthcdr (TOP, arg);
1142 Lisp_Object arg = POP;
1143 TOP = Felt (TOP, arg);
1149 Lisp_Object arg = POP;
1150 TOP = Fmember (TOP, arg);
1155 TOP = Fgoto_char (TOP, Qnil);
1158 case Bcurrent_buffer:
1161 XSETBUFFER (buffer, current_buffer);
1167 TOP = Fset_buffer (TOP);
1171 PUSH (make_int (BUF_ZV (current_buffer)));
1175 PUSH (make_int (BUF_BEGV (current_buffer)));
1178 case Bskip_chars_forward:
1180 Lisp_Object arg = POP;
1181 TOP = Fskip_chars_forward (TOP, arg, Qnil);
1187 Lisp_Object arg = POP;
1188 TOP = Fassq (TOP, arg);
1194 Lisp_Object arg = POP;
1195 TOP = Fsetcar (TOP, arg);
1201 Lisp_Object arg = POP;
1202 TOP = Fsetcdr (TOP, arg);
1207 TOP = bytecode_nreverse (TOP);
1211 TOP = CONSP (TOP) ? XCAR (TOP) : Qnil;
1215 TOP = CONSP (TOP) ? XCDR (TOP) : Qnil;
1222 /* It makes a worthwhile performance difference (5%) to shunt
1223 lesser-used opcodes off to a subroutine, to keep the switch in
1224 execute_optimized_program small. If you REALLY care about
1225 performance, you want to keep your heavily executed code away from
1226 rarely executed code, to minimize cache misses.
1228 Don't make this function static, since then the compiler might inline it. */
1230 execute_rare_opcode (Lisp_Object *stack_ptr,
1231 CONST Opbyte *program_ptr,
1237 case Bsave_excursion:
1238 record_unwind_protect (save_excursion_restore,
1239 save_excursion_save ());
1242 case Bsave_window_excursion:
1244 int count = specpdl_depth ();
1245 record_unwind_protect (save_window_excursion_unwind,
1246 Fcurrent_window_configuration (Qnil));
1248 unbind_to (count, Qnil);
1252 case Bsave_restriction:
1253 record_unwind_protect (save_restriction_restore,
1254 save_restriction_save ());
1259 Lisp_Object arg = POP;
1260 TOP = internal_catch (TOP, Feval, arg, 0);
1264 case Bskip_chars_backward:
1266 Lisp_Object arg = POP;
1267 TOP = Fskip_chars_backward (TOP, arg, Qnil);
1271 case Bunwind_protect:
1272 record_unwind_protect (Fprogn, POP);
1275 case Bcondition_case:
1277 Lisp_Object arg2 = POP; /* handlers */
1278 Lisp_Object arg1 = POP; /* bodyform */
1279 TOP = condition_case_3 (arg1, TOP, arg2);
1285 Lisp_Object arg2 = POP;
1286 Lisp_Object arg1 = POP;
1287 TOP = Fset_marker (TOP, arg1, arg2);
1293 Lisp_Object arg = POP;
1294 TOP = Frem (TOP, arg);
1298 case Bmatch_beginning:
1299 TOP = Fmatch_beginning (TOP);
1303 TOP = Fmatch_end (TOP);
1307 TOP = Fupcase (TOP, Qnil);
1311 TOP = Fdowncase (TOP, Qnil);
1316 Lisp_Object arg = POP;
1317 TOP = Ffset (TOP, arg);
1323 Lisp_Object arg = POP;
1324 TOP = Fstring_equal (TOP, arg);
1330 Lisp_Object arg = POP;
1331 TOP = Fstring_lessp (TOP, arg);
1337 Lisp_Object arg2 = POP;
1338 Lisp_Object arg1 = POP;
1339 TOP = Fsubstring (TOP, arg1, arg2);
1343 case Bcurrent_column:
1344 PUSH (make_int (current_column (current_buffer)));
1348 TOP = Fchar_after (TOP, Qnil);
1352 TOP = Findent_to (TOP, Qnil, Qnil);
1356 PUSH (Fwiden (Qnil));
1359 case Bfollowing_char:
1360 PUSH (Ffollowing_char (Qnil));
1363 case Bpreceding_char:
1364 PUSH (Fpreceding_char (Qnil));
1368 PUSH (Feolp (Qnil));
1372 PUSH (Feobp (Qnil));
1376 PUSH (Fbolp (Qnil));
1380 PUSH (Fbobp (Qnil));
1383 case Bsave_current_buffer:
1384 record_unwind_protect (save_current_buffer_restore,
1385 Fcurrent_buffer ());
1388 case Binteractive_p:
1389 PUSH (Finteractive_p ());
1393 TOP = Fforward_char (TOP, Qnil);
1397 TOP = Fforward_word (TOP, Qnil);
1401 TOP = Fforward_line (TOP, Qnil);
1405 TOP = Fchar_syntax (TOP, Qnil);
1408 case Bbuffer_substring:
1410 Lisp_Object arg = POP;
1411 TOP = Fbuffer_substring (TOP, arg, Qnil);
1415 case Bdelete_region:
1417 Lisp_Object arg = POP;
1418 TOP = Fdelete_region (TOP, arg, Qnil);
1422 case Bnarrow_to_region:
1424 Lisp_Object arg = POP;
1425 TOP = Fnarrow_to_region (TOP, arg, Qnil);
1430 TOP = Fend_of_line (TOP, Qnil);
1433 case Btemp_output_buffer_setup:
1434 temp_output_buffer_setup (TOP);
1435 TOP = Vstandard_output;
1438 case Btemp_output_buffer_show:
1440 Lisp_Object arg = POP;
1441 temp_output_buffer_show (TOP, Qnil);
1444 /* pop binding of standard-output */
1445 unbind_to (specpdl_depth() - 1, Qnil);
1451 Lisp_Object arg = POP;
1452 TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
1458 Lisp_Object arg = POP;
1459 TOP = Fold_memq (TOP, arg);
1465 Lisp_Object arg = POP;
1466 TOP = Fold_equal (TOP, arg);
1472 Lisp_Object arg = POP;
1473 TOP = Fold_member (TOP, arg);
1479 Lisp_Object arg = POP;
1480 TOP = Fold_assq (TOP, arg);
1493 invalid_byte_code_error (char *error_message, ...)
1497 char *buf = alloca_array (char, strlen (error_message) + 128);
1499 sprintf (buf, "%s", error_message);
1500 va_start (args, error_message);
1501 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (buf), Qnil, -1,
1505 signal_error (Qinvalid_byte_code, list1 (obj));
1508 /* Check for valid opcodes. Change this when adding new opcodes. */
1510 check_opcode (Opcode opcode)
1512 if ((opcode < Bvarref) ||
1514 (opcode > Bassq && opcode < Bconstant))
1515 invalid_byte_code_error
1516 ("invalid opcode %d in instruction stream", opcode);
1519 /* Check that IDX is a valid offset into the `constants' vector */
1521 check_constants_index (int idx, Lisp_Object constants)
1523 if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
1524 invalid_byte_code_error
1525 ("reference %d to constants array out of range 0, %d",
1526 idx, XVECTOR_LENGTH (constants) - 1);
1529 /* Get next character from Lisp instructions string. */
1530 #define READ_INSTRUCTION_CHAR(lvalue) do { \
1531 (lvalue) = charptr_emchar (ptr); \
1532 INC_CHARPTR (ptr); \
1533 *icounts_ptr++ = program_ptr - program; \
1534 if (lvalue > UCHAR_MAX) \
1535 invalid_byte_code_error \
1536 ("Invalid character %c in byte code string"); \
1539 /* Get opcode from Lisp instructions string. */
1540 #define READ_OPCODE do { \
1542 READ_INSTRUCTION_CHAR (c); \
1543 opcode = (Opcode) c; \
1546 /* Get next operand, a uint8, from Lisp instructions string. */
1547 #define READ_OPERAND_1 do { \
1548 READ_INSTRUCTION_CHAR (arg); \
1552 /* Get next operand, a uint16, from Lisp instructions string. */
1553 #define READ_OPERAND_2 do { \
1554 unsigned int arg1, arg2; \
1555 READ_INSTRUCTION_CHAR (arg1); \
1556 READ_INSTRUCTION_CHAR (arg2); \
1557 arg = arg1 + (arg2 << 8); \
1561 /* Write 1 byte to PTR, incrementing PTR */
1562 #define WRITE_INT8(value, ptr) do { \
1563 *((ptr)++) = (value); \
1566 /* Write 2 bytes to PTR, incrementing PTR */
1567 #define WRITE_INT16(value, ptr) do { \
1568 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \
1569 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \
1572 /* We've changed our minds about the opcode we've already written. */
1573 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
1575 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
1576 #define WRITE_NARGS(base_opcode) do { \
1579 REWRITE_OPCODE (base_opcode + arg); \
1581 else if (arg <= UCHAR_MAX) \
1583 REWRITE_OPCODE (base_opcode + 6); \
1584 WRITE_INT8 (arg, program_ptr); \
1588 REWRITE_OPCODE (base_opcode + 7); \
1589 WRITE_INT16 (arg, program_ptr); \
1593 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
1594 #define WRITE_CONSTANT do { \
1595 check_constants_index(arg, constants); \
1596 if (arg <= UCHAR_MAX - Bconstant) \
1598 REWRITE_OPCODE (Bconstant + arg); \
1602 REWRITE_OPCODE (Bconstant2); \
1603 WRITE_INT16 (arg, program_ptr); \
1607 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
1609 /* Compile byte code instructions into free space provided by caller, with
1610 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
1611 Returns length of compiled code. */
1613 optimize_byte_code (/* in */
1614 Lisp_Object instructions,
1615 Lisp_Object constants,
1617 Opbyte * CONST program,
1618 int * CONST program_length,
1619 int * CONST varbind_count)
1621 size_t instructions_length = XSTRING_LENGTH (instructions);
1622 size_t comfy_size = 2 * instructions_length;
1624 int * CONST icounts = alloca_array (int, comfy_size);
1625 int * icounts_ptr = icounts;
1627 /* We maintain a table of jumps in the source code. */
1633 struct jump * CONST jumps = alloca_array (struct jump, comfy_size);
1634 struct jump *jumps_ptr = jumps;
1636 Opbyte *program_ptr = program;
1638 CONST Bufbyte *ptr = XSTRING_DATA (instructions);
1639 CONST Bufbyte * CONST end = ptr + instructions_length;
1655 case Bvarref+7: READ_OPERAND_2; goto do_varref;
1656 case Bvarref+6: READ_OPERAND_1; goto do_varref;
1657 case Bvarref: case Bvarref+1: case Bvarref+2:
1658 case Bvarref+3: case Bvarref+4: case Bvarref+5:
1659 arg = opcode - Bvarref;
1661 check_constants_index (arg, constants);
1662 val = XVECTOR_DATA (constants) [arg];
1664 invalid_byte_code_error ("variable reference to non-symbol %S", val);
1665 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1666 invalid_byte_code_error ("variable reference to constant symbol %s",
1667 string_data (XSYMBOL (val)->name));
1668 WRITE_NARGS (Bvarref);
1671 case Bvarset+7: READ_OPERAND_2; goto do_varset;
1672 case Bvarset+6: READ_OPERAND_1; goto do_varset;
1673 case Bvarset: case Bvarset+1: case Bvarset+2:
1674 case Bvarset+3: case Bvarset+4: case Bvarset+5:
1675 arg = opcode - Bvarset;
1677 check_constants_index (arg, constants);
1678 val = XVECTOR_DATA (constants) [arg];
1680 invalid_byte_code_error ("attempt to set non-symbol %S", val);
1681 if (EQ (val, Qnil) || EQ (val, Qt))
1682 invalid_byte_code_error ("attempt to set constant symbol %s",
1683 string_data (XSYMBOL (val)->name));
1684 /* Ignore assignments to keywords by converting to Bdiscard.
1685 For backward compatibility only - we'd like to make this an error. */
1686 if (SYMBOL_IS_KEYWORD (val))
1687 REWRITE_OPCODE (Bdiscard);
1689 WRITE_NARGS (Bvarset);
1692 case Bvarbind+7: READ_OPERAND_2; goto do_varbind;
1693 case Bvarbind+6: READ_OPERAND_1; goto do_varbind;
1694 case Bvarbind: case Bvarbind+1: case Bvarbind+2:
1695 case Bvarbind+3: case Bvarbind+4: case Bvarbind+5:
1696 arg = opcode - Bvarbind;
1699 check_constants_index (arg, constants);
1700 val = XVECTOR_DATA (constants) [arg];
1702 invalid_byte_code_error ("attempt to let-bind non-symbol %S", val);
1703 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1704 invalid_byte_code_error ("attempt to let-bind constant symbol %s",
1705 string_data (XSYMBOL (val)->name));
1706 WRITE_NARGS (Bvarbind);
1709 case Bcall+7: READ_OPERAND_2; goto do_call;
1710 case Bcall+6: READ_OPERAND_1; goto do_call;
1711 case Bcall: case Bcall+1: case Bcall+2:
1712 case Bcall+3: case Bcall+4: case Bcall+5:
1713 arg = opcode - Bcall;
1715 WRITE_NARGS (Bcall);
1718 case Bunbind+7: READ_OPERAND_2; goto do_unbind;
1719 case Bunbind+6: READ_OPERAND_1; goto do_unbind;
1720 case Bunbind: case Bunbind+1: case Bunbind+2:
1721 case Bunbind+3: case Bunbind+4: case Bunbind+5:
1722 arg = opcode - Bunbind;
1724 WRITE_NARGS (Bunbind);
1730 case Bgotoifnilelsepop:
1731 case Bgotoifnonnilelsepop:
1733 /* Make program_ptr-relative */
1734 arg += icounts - (icounts_ptr - argsize);
1739 case BRgotoifnonnil:
1740 case BRgotoifnilelsepop:
1741 case BRgotoifnonnilelsepop:
1743 /* Make program_ptr-relative */
1746 /* Record program-relative goto addresses in `jumps' table */
1747 jumps_ptr->from = icounts_ptr - icounts - argsize;
1748 jumps_ptr->to = jumps_ptr->from + arg;
1750 if (arg >= -1 && arg <= argsize)
1751 invalid_byte_code_error
1752 ("goto instruction is its own target");
1753 if (arg <= SCHAR_MIN ||
1757 REWRITE_OPCODE (opcode + Bgoto - BRgoto);
1758 WRITE_INT16 (arg, program_ptr);
1763 REWRITE_OPCODE (opcode + BRgoto - Bgoto);
1764 WRITE_INT8 (arg, program_ptr);
1777 WRITE_INT8 (arg, program_ptr);
1781 if (opcode < Bconstant)
1782 check_opcode (opcode);
1785 arg = opcode - Bconstant;
1792 /* Fix up jumps table to refer to NEW offsets. */
1795 for (j = jumps; j < jumps_ptr; j++)
1797 #ifdef ERROR_CHECK_BYTE_CODE
1798 assert (j->from < icounts_ptr - icounts);
1799 assert (j->to < icounts_ptr - icounts);
1801 j->from = icounts[j->from];
1802 j->to = icounts[j->to];
1803 #ifdef ERROR_CHECK_BYTE_CODE
1804 assert (j->from < program_ptr - program);
1805 assert (j->to < program_ptr - program);
1806 check_opcode ((Opcode) (program[j->from-1]));
1808 check_opcode ((Opcode) (program[j->to]));
1812 /* Fixup jumps in byte-code until no more fixups needed */
1814 int more_fixups_needed = 1;
1816 while (more_fixups_needed)
1819 more_fixups_needed = 0;
1820 for (j = jumps; j < jumps_ptr; j++)
1824 int jump = to - from;
1825 Opbyte *p = program + from;
1826 Opcode opcode = (Opcode) p[-1];
1827 if (!more_fixups_needed)
1828 check_opcode ((Opcode) p[jump]);
1829 assert (to >= 0 && program + to < program_ptr);
1835 case Bgotoifnilelsepop:
1836 case Bgotoifnonnilelsepop:
1837 WRITE_INT16 (jump, p);
1842 case BRgotoifnonnil:
1843 case BRgotoifnilelsepop:
1844 case BRgotoifnonnilelsepop:
1845 if (jump > SCHAR_MIN &&
1848 WRITE_INT8 (jump, p);
1853 for (jj = jumps; jj < jumps_ptr; jj++)
1855 assert (jj->from < program_ptr - program);
1856 assert (jj->to < program_ptr - program);
1857 if (jj->from > from) jj->from++;
1858 if (jj->to > from) jj->to++;
1860 p[-1] += Bgoto - BRgoto;
1861 more_fixups_needed = 1;
1862 memmove (p+1, p, program_ptr++ - p);
1863 WRITE_INT16 (jump, p);
1875 /* *program_ptr++ = 0; */
1876 *program_length = program_ptr - program;
1879 /* Optimize the byte code and store the optimized program, only
1880 understood by bytecode.c, in an opaque object in the
1881 instructions slot of the Compiled_Function object. */
1883 optimize_compiled_function (Lisp_Object compiled_function)
1885 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
1890 /* If we have not actually read the bytecode string
1891 and constants vector yet, fetch them from the file. */
1892 if (CONSP (f->instructions))
1893 Ffetch_bytecode (compiled_function);
1895 if (STRINGP (f->instructions))
1897 /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1898 which would be slightly more `proper' */
1899 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
1900 optimize_byte_code (f->instructions, f->constants,
1901 program, &program_length, &varbind_count);
1902 f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
1904 Fpurecopy (make_opaque (program_length * sizeof (Opbyte),
1905 (CONST void *) program));
1908 assert (OPAQUEP (f->instructions));
1911 /************************************************************************/
1912 /* The compiled-function object type */
1913 /************************************************************************/
1915 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
1918 /* This function can GC */
1919 Lisp_Compiled_Function *f =
1920 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
1921 int docp = f->flags.documentationp;
1922 int intp = f->flags.interactivep;
1923 struct gcpro gcpro1, gcpro2;
1925 GCPRO2 (obj, printcharfun);
1927 write_c_string (print_readably ? "#[" : "#<compiled-function ", printcharfun);
1928 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1929 if (!print_readably)
1931 Lisp_Object ann = compiled_function_annotation (f);
1934 write_c_string ("(from ", printcharfun);
1935 print_internal (ann, printcharfun, 1);
1936 write_c_string (") ", printcharfun);
1939 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1940 /* COMPILED_ARGLIST = 0 */
1941 print_internal (compiled_function_arglist (f), printcharfun, escapeflag);
1943 /* COMPILED_INSTRUCTIONS = 1 */
1944 write_c_string (" ", printcharfun);
1946 struct gcpro ngcpro1;
1947 Lisp_Object instructions = compiled_function_instructions (f);
1948 NGCPRO1 (instructions);
1949 if (STRINGP (instructions) && !print_readably)
1951 /* We don't usually want to see that junk in the bytecode. */
1952 sprintf (buf, "\"...(%ld)\"",
1953 (long) XSTRING_CHAR_LENGTH (instructions));
1954 write_c_string (buf, printcharfun);
1957 print_internal (instructions, printcharfun, escapeflag);
1961 /* COMPILED_CONSTANTS = 2 */
1962 write_c_string (" ", printcharfun);
1963 print_internal (compiled_function_constants (f), printcharfun, escapeflag);
1965 /* COMPILED_STACK_DEPTH = 3 */
1966 sprintf (buf, " %d", compiled_function_stack_depth (f));
1967 write_c_string (buf, printcharfun);
1969 /* COMPILED_DOC_STRING = 4 */
1972 write_c_string (" ", printcharfun);
1973 print_internal (compiled_function_documentation (f), printcharfun,
1977 /* COMPILED_INTERACTIVE = 5 */
1980 write_c_string (" ", printcharfun);
1981 print_internal (compiled_function_interactive (f), printcharfun,
1986 write_c_string (print_readably ? "]" : ">", printcharfun);
1991 mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object))
1993 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1995 markobj (f->instructions);
1996 markobj (f->arglist);
1997 markobj (f->doc_and_interactive);
1998 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1999 markobj (f->annotated);
2001 /* tail-recurse on constants */
2002 return f->constants;
2006 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2008 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1);
2009 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
2011 (f1->flags.documentationp == f2->flags.documentationp &&
2012 f1->flags.interactivep == f2->flags.interactivep &&
2013 f1->flags.domainp == f2->flags.domainp && /* I18N3 */
2014 internal_equal (compiled_function_instructions (f1),
2015 compiled_function_instructions (f2), depth + 1) &&
2016 internal_equal (f1->constants, f2->constants, depth + 1) &&
2017 internal_equal (f1->arglist, f2->arglist, depth + 1) &&
2018 internal_equal (f1->doc_and_interactive,
2019 f2->doc_and_interactive, depth + 1));
2022 static unsigned long
2023 compiled_function_hash (Lisp_Object obj, int depth)
2025 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
2026 return HASH3 ((f->flags.documentationp << 2) +
2027 (f->flags.interactivep << 1) +
2029 internal_hash (f->instructions, depth + 1),
2030 internal_hash (f->constants, depth + 1));
2033 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
2034 mark_compiled_function,
2035 print_compiled_function, 0,
2036 compiled_function_equal,
2037 compiled_function_hash,
2038 Lisp_Compiled_Function);
2040 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
2041 Return t if OBJECT is a byte-compiled function object.
2045 return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
2048 /************************************************************************/
2049 /* compiled-function object accessor functions */
2050 /************************************************************************/
2053 compiled_function_arglist (Lisp_Compiled_Function *f)
2059 compiled_function_instructions (Lisp_Compiled_Function *f)
2061 if (! OPAQUEP (f->instructions))
2062 return f->instructions;
2065 /* Invert action performed by optimize_byte_code() */
2066 Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2068 Bufbyte * CONST buffer =
2069 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2070 Bufbyte *bp = buffer;
2072 CONST Opbyte * CONST program = (CONST Opbyte *) OPAQUE_DATA (opaque);
2073 CONST Opbyte *program_ptr = program;
2074 CONST Opbyte * CONST program_end = program_ptr + OPAQUE_SIZE (opaque);
2076 while (program_ptr < program_end)
2078 Opcode opcode = (Opcode) READ_UINT_1;
2079 bp += set_charptr_emchar (bp, opcode);
2088 bp += set_charptr_emchar (bp, READ_UINT_1);
2089 bp += set_charptr_emchar (bp, READ_UINT_1);
2100 bp += set_charptr_emchar (bp, READ_UINT_1);
2106 case Bgotoifnilelsepop:
2107 case Bgotoifnonnilelsepop:
2109 int jump = READ_INT_2;
2111 Opbyte *buf2p = buf2;
2112 /* Convert back to program-relative address */
2113 WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
2114 bp += set_charptr_emchar (bp, buf2[0]);
2115 bp += set_charptr_emchar (bp, buf2[1]);
2121 case BRgotoifnonnil:
2122 case BRgotoifnilelsepop:
2123 case BRgotoifnonnilelsepop:
2124 bp += set_charptr_emchar (bp, READ_INT_1 + 127);
2131 return make_string (buffer, bp - buffer);
2136 compiled_function_constants (Lisp_Compiled_Function *f)
2138 return f->constants;
2142 compiled_function_stack_depth (Lisp_Compiled_Function *f)
2144 return f->stack_depth;
2147 /* The compiled_function->doc_and_interactive slot uses the minimal
2148 number of conses, based on compiled_function->flags; it may take
2149 any of the following forms:
2156 (interactive . domain)
2157 (doc . (interactive . domain))
2160 /* Caller must check flags.interactivep first */
2162 compiled_function_interactive (Lisp_Compiled_Function *f)
2164 assert (f->flags.interactivep);
2165 if (f->flags.documentationp && f->flags.domainp)
2166 return XCAR (XCDR (f->doc_and_interactive));
2167 else if (f->flags.documentationp)
2168 return XCDR (f->doc_and_interactive);
2169 else if (f->flags.domainp)
2170 return XCAR (f->doc_and_interactive);
2172 return f->doc_and_interactive;
2175 /* Caller need not check flags.documentationp first */
2177 compiled_function_documentation (Lisp_Compiled_Function *f)
2179 if (! f->flags.documentationp)
2181 else if (f->flags.interactivep && f->flags.domainp)
2182 return XCAR (f->doc_and_interactive);
2183 else if (f->flags.interactivep)
2184 return XCAR (f->doc_and_interactive);
2185 else if (f->flags.domainp)
2186 return XCAR (f->doc_and_interactive);
2188 return f->doc_and_interactive;
2191 /* Caller need not check flags.domainp first */
2193 compiled_function_domain (Lisp_Compiled_Function *f)
2195 if (! f->flags.domainp)
2197 else if (f->flags.documentationp && f->flags.interactivep)
2198 return XCDR (XCDR (f->doc_and_interactive));
2199 else if (f->flags.documentationp)
2200 return XCDR (f->doc_and_interactive);
2201 else if (f->flags.interactivep)
2202 return XCDR (f->doc_and_interactive);
2204 return f->doc_and_interactive;
2207 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2210 compiled_function_annotation (Lisp_Compiled_Function *f)
2212 return f->annotated;
2217 /* used only by Snarf-documentation; there must be doc already. */
2219 set_compiled_function_documentation (Lisp_Compiled_Function *f,
2220 Lisp_Object new_doc)
2222 assert (f->flags.documentationp);
2223 assert (INTP (new_doc) || STRINGP (new_doc));
2225 if (f->flags.interactivep && f->flags.domainp)
2226 XCAR (f->doc_and_interactive) = new_doc;
2227 else if (f->flags.interactivep)
2228 XCAR (f->doc_and_interactive) = new_doc;
2229 else if (f->flags.domainp)
2230 XCAR (f->doc_and_interactive) = new_doc;
2232 f->doc_and_interactive = new_doc;
2236 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2237 Return the argument list of the compiled-function object FUNCTION.
2241 CHECK_COMPILED_FUNCTION (function);
2242 return compiled_function_arglist (XCOMPILED_FUNCTION (function));
2245 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
2246 Return the byte-opcode string of the compiled-function object FUNCTION.
2250 CHECK_COMPILED_FUNCTION (function);
2251 return compiled_function_instructions (XCOMPILED_FUNCTION (function));
2254 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
2255 Return the constants vector of the compiled-function object FUNCTION.
2259 CHECK_COMPILED_FUNCTION (function);
2260 return compiled_function_constants (XCOMPILED_FUNCTION (function));
2263 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2264 Return the max stack depth of the compiled-function object FUNCTION.
2268 CHECK_COMPILED_FUNCTION (function);
2269 return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
2272 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
2273 Return the doc string of the compiled-function object FUNCTION, if available.
2274 Functions that had their doc strings snarfed into the DOC file will have
2275 an integer returned instead of a string.
2279 CHECK_COMPILED_FUNCTION (function);
2280 return compiled_function_documentation (XCOMPILED_FUNCTION (function));
2283 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2284 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2285 If non-nil, the return value will be a list whose first element is
2286 `interactive' and whose second element is the interactive spec.
2290 CHECK_COMPILED_FUNCTION (function);
2291 return XCOMPILED_FUNCTION (function)->flags.interactivep
2292 ? list2 (Qinteractive,
2293 compiled_function_interactive (XCOMPILED_FUNCTION (function)))
2297 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2299 /* Remove the `xx' if you wish to restore this feature */
2300 xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2301 Return the annotation of the compiled-function object FUNCTION, or nil.
2302 The annotation is a piece of information indicating where this
2303 compiled-function object came from. Generally this will be
2304 a symbol naming a function; or a string naming a file, if the
2305 compiled-function object was not defined in a function; or nil,
2306 if the compiled-function object was not created as a result of
2311 CHECK_COMPILED_FUNCTION (function);
2312 return compiled_function_annotation (XCOMPILED_FUNCTION (function));
2315 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2317 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
2318 Return the domain of the compiled-function object FUNCTION, or nil.
2319 This is only meaningful if I18N3 was enabled when emacs was compiled.
2323 CHECK_COMPILED_FUNCTION (function);
2324 return XCOMPILED_FUNCTION (function)->flags.domainp
2325 ? compiled_function_domain (XCOMPILED_FUNCTION (function))
2331 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
2332 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2336 Lisp_Compiled_Function *f;
2337 CHECK_COMPILED_FUNCTION (function);
2338 f = XCOMPILED_FUNCTION (function);
2340 if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
2343 if (CONSP (f->instructions))
2345 Lisp_Object tem = read_doc_string (f->instructions);
2347 signal_simple_error ("Invalid lazy-loaded byte code", tem);
2348 /* v18 or v19 bytecode file. Need to Ebolify. */
2349 if (f->flags.ebolified && VECTORP (XCDR (tem)))
2350 ebolify_bytecode_constants (XCDR (tem));
2351 /* VERY IMPORTANT to purecopy here!!!!!
2352 See load_force_doc_string_unwind. */
2353 f->instructions = Fpurecopy (XCAR (tem));
2354 f->constants = Fpurecopy (XCDR (tem));
2358 return Qnil; /* not reached */
2361 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
2362 Convert compiled function FUNCTION into an optimized internal form.
2366 Lisp_Compiled_Function *f;
2367 CHECK_COMPILED_FUNCTION (function);
2368 f = XCOMPILED_FUNCTION (function);
2370 if (OPAQUEP (f->instructions)) /* Already optimized? */
2373 optimize_compiled_function (function);
2377 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
2378 Function used internally in byte-compiled code.
2379 First argument INSTRUCTIONS is a string of byte code.
2380 Second argument CONSTANTS is a vector of constants.
2381 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2382 If STACK-DEPTH is incorrect, Emacs may crash.
2384 (instructions, constants, stack_depth))
2386 /* This function can GC */
2391 CHECK_STRING (instructions);
2392 CHECK_VECTOR (constants);
2393 CHECK_NATNUM (stack_depth);
2395 /* Optimize the `instructions' string, just like when executing a
2396 regular compiled function, but don't save it for later since this is
2397 likely to only be executed once. */
2398 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
2399 optimize_byte_code (instructions, constants, program,
2400 &program_length, &varbind_count);
2401 SPECPDL_RESERVE (varbind_count);
2402 return execute_optimized_program (program,
2404 XVECTOR_DATA (constants));
2409 syms_of_bytecode (void)
2411 deferror (&Qinvalid_byte_code, "invalid-byte-code",
2412 "Invalid byte code", Qerror);
2413 defsymbol (&Qbyte_code, "byte-code");
2414 defsymbol (&Qcompiled_functionp, "compiled-function-p");
2416 DEFSUBR (Fbyte_code);
2417 DEFSUBR (Ffetch_bytecode);
2418 DEFSUBR (Foptimize_compiled_function);
2420 DEFSUBR (Fcompiled_function_p);
2421 DEFSUBR (Fcompiled_function_instructions);
2422 DEFSUBR (Fcompiled_function_constants);
2423 DEFSUBR (Fcompiled_function_stack_depth);
2424 DEFSUBR (Fcompiled_function_arglist);
2425 DEFSUBR (Fcompiled_function_interactive);
2426 DEFSUBR (Fcompiled_function_doc_string);
2427 DEFSUBR (Fcompiled_function_domain);
2428 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2429 DEFSUBR (Fcompiled_function_annotation);
2432 #ifdef BYTE_CODE_METER
2433 defsymbol (&Qbyte_code_meter, "byte-code-meter");
2438 vars_of_bytecode (void)
2440 #ifdef BYTE_CODE_METER
2442 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
2443 A vector of vectors which holds a histogram of byte code usage.
2444 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2445 opcode CODE has been executed.
2446 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2447 indicates how many times the byte opcodes CODE1 and CODE2 have been
2448 executed in succession.
2450 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /*
2451 If non-nil, keep profiling information on byte code usage.
2452 The variable `byte-code-meter' indicates how often each byte opcode is used.
2453 If a symbol has a property named `byte-code-meter' whose value is an
2454 integer, it is incremented each time that symbol's function is called.
2457 byte_metering_on = 0;
2458 Vbyte_code_meter = make_vector (256, Qzero);
2462 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
2464 #endif /* BYTE_CODE_METER */