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@jwz.org 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"
61 EXFUN (Ffetch_bytecode, 1);
63 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
65 enum Opcode /* Byte codes */
92 Bsymbol_function = 0113,
115 Beq = 0141, /* was Bmark,
116 but no longer generated as of v18 */
122 Bfollowing_char = 0147,
123 Bpreceding_char = 0150,
124 Bcurrent_column = 0151,
126 Bequal = 0153, /* was Bscan_buffer,
127 but no longer generated as of v18 */
132 Bcurrent_buffer = 0160,
134 Bsave_current_buffer = 0162, /* was Bread_char,
135 but no longer generated as of v19 */
136 Bmemq = 0163, /* was Bset_mark,
137 but no longer generated as of v18 */
138 Binteractive_p = 0164, /* Needed since interactive-p takes
140 Bforward_char = 0165,
141 Bforward_word = 0166,
142 Bskip_chars_forward = 0167,
143 Bskip_chars_backward = 0170,
144 Bforward_line = 0171,
146 Bbuffer_substring = 0173,
147 Bdelete_region = 0174,
148 Bnarrow_to_region = 0175,
155 Bgotoifnonnil = 0204,
156 Bgotoifnilelsepop = 0205,
157 Bgotoifnonnilelsepop = 0206,
162 Bsave_excursion = 0212,
163 Bsave_window_excursion= 0213,
164 Bsave_restriction = 0214,
167 Bunwind_protect = 0216,
168 Bcondition_case = 0217,
169 Btemp_output_buffer_setup = 0220,
170 Btemp_output_buffer_show = 0221,
175 Bmatch_beginning = 0224,
180 Bstring_equal = 0230,
181 Bstring_lessp = 0231,
200 BRgotoifnonnil = 0254,
201 BRgotoifnilelsepop = 0255,
202 BRgotoifnonnilelsepop = 0256,
207 Bmember = 0266, /* new in v20 */
208 Bassq = 0267, /* new in v20 */
212 typedef enum Opcode Opcode;
213 typedef unsigned char Opbyte;
216 static void invalid_byte_code_error (char *error_message, ...);
218 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
219 const Opbyte *program_ptr,
222 static Lisp_Object execute_optimized_program (const Opbyte *program,
224 Lisp_Object *constants_data);
226 extern Lisp_Object Qand_rest, Qand_optional;
228 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
229 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
230 /* #define BYTE_CODE_METER */
233 #ifdef BYTE_CODE_METER
235 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
236 int byte_metering_on;
239 meter_code (Opcode prev_opcode, Opcode this_opcode)
241 if (byte_metering_on)
243 Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]);
244 p[0] = INT_PLUS1 (p[0]);
246 p[prev_opcode] = INT_PLUS1 (p[prev_opcode]);
250 #endif /* BYTE_CODE_METER */
254 bytecode_negate (Lisp_Object obj)
258 if (INTP (obj)) return make_int (- XINT (obj));
259 #ifdef LISP_FLOAT_TYPE
260 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
262 if (CHARP (obj)) return make_int (- ((int) XCHAR (obj)));
263 if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));
265 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
270 bytecode_nreverse (Lisp_Object list)
272 REGISTER Lisp_Object prev = Qnil;
273 REGISTER Lisp_Object tail = list;
277 REGISTER Lisp_Object next;
288 /* We have our own two-argument versions of various arithmetic ops.
289 Only two-argument arithmetic operations have their own byte codes. */
291 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2)
295 #ifdef LISP_FLOAT_TYPE
297 EMACS_INT ival1, ival2;
299 if (INTP (obj1)) ival1 = XINT (obj1);
300 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
301 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
302 else goto arithcompare_float;
304 if (INTP (obj2)) ival2 = XINT (obj2);
305 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
306 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
307 else goto arithcompare_float;
309 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
317 if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1);
318 else if (INTP (obj1)) dval1 = (double) XINT (obj1);
319 else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1);
320 else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1);
323 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
327 if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2);
328 else if (INTP (obj2)) dval2 = (double) XINT (obj2);
329 else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2);
330 else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2);
333 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
337 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
339 #else /* !LISP_FLOAT_TYPE */
341 EMACS_INT ival1, ival2;
343 if (INTP (obj1)) ival1 = XINT (obj1);
344 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
345 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
348 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
352 if (INTP (obj2)) ival2 = XINT (obj2);
353 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
354 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
357 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
361 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
363 #endif /* !LISP_FLOAT_TYPE */
367 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
369 #ifdef LISP_FLOAT_TYPE
370 EMACS_INT ival1, ival2;
377 if (INTP (obj1)) ival1 = XINT (obj1);
378 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
379 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
380 else if (FLOATP (obj1)) ival1 = 0, float_p = 1;
383 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
387 if (INTP (obj2)) ival2 = XINT (obj2);
388 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
389 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
390 else if (FLOATP (obj2)) ival2 = 0, float_p = 1;
393 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
401 case Bplus: ival1 += ival2; break;
402 case Bdiff: ival1 -= ival2; break;
403 case Bmult: ival1 *= ival2; break;
405 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
408 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
409 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
411 return make_int (ival1);
415 double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1;
416 double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2;
419 case Bplus: dval1 += dval2; break;
420 case Bdiff: dval1 -= dval2; break;
421 case Bmult: dval1 *= dval2; break;
423 if (dval2 == 0) Fsignal (Qarith_error, Qnil);
426 case Bmax: if (dval1 < dval2) dval1 = dval2; break;
427 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
429 return make_float (dval1);
431 #else /* !LISP_FLOAT_TYPE */
432 EMACS_INT ival1, ival2;
436 if (INTP (obj1)) ival1 = XINT (obj1);
437 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
438 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
441 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
445 if (INTP (obj2)) ival2 = XINT (obj2);
446 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
447 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
450 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
456 case Bplus: ival1 += ival2; break;
457 case Bdiff: ival1 -= ival2; break;
458 case Bmult: ival1 *= ival2; break;
460 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
463 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
464 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
466 return make_int (ival1);
467 #endif /* !LISP_FLOAT_TYPE */
470 /* Apply compiled-function object FUN to the NARGS evaluated arguments
471 in ARGS, and return the result of evaluation. */
473 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[])
475 /* This function can GC */
476 Lisp_Object symbol, tail;
477 int speccount = specpdl_depth();
479 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
482 if (!OPAQUEP (f->instructions))
483 /* Lazily munge the instructions into a more efficient form */
484 optimize_compiled_function (fun);
486 /* optimize_compiled_function() guaranteed that f->specpdl_depth is
487 the required space on the specbinding stack for binding the args
488 and local variables of fun. So just reserve it once. */
489 SPECPDL_RESERVE (f->specpdl_depth);
491 /* Fmake_byte_code() guaranteed that f->arglist is a valid list
492 containing only non-constant symbols. */
493 LIST_LOOP_3 (symbol, f->arglist, tail)
495 if (EQ (symbol, Qand_rest))
498 symbol = XCAR (tail);
499 SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i]));
502 else if (EQ (symbol, Qand_optional))
504 else if (i == nargs && !optional)
505 goto wrong_number_of_arguments;
507 SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil);
511 goto wrong_number_of_arguments;
517 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions),
519 XVECTOR_DATA (f->constants));
521 /* The attempt to optimize this by only unbinding variables failed
522 because using buffer-local variables as function parameters
523 leads to specpdl_ptr->func != 0 */
524 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */
525 UNBIND_TO_GCPRO (speccount, value);
529 wrong_number_of_arguments:
530 /* The actual printed compiled_function object is incomprehensible.
531 Check the backtrace to see if we can get a more meaningful symbol. */
532 if (EQ (fun, indirect_function (*backtrace_list->function, 0)))
533 fun = *backtrace_list->function;
534 return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
538 /* Read next uint8 from the instruction stream. */
539 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
541 /* Read next uint16 from the instruction stream. */
542 #define READ_UINT_2 \
544 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \
545 ((unsigned int) (unsigned char) program_ptr[-2])))
547 /* Read next int8 from the instruction stream. */
548 #define READ_INT_1 ((int) (signed char) *program_ptr++)
550 /* Read next int16 from the instruction stream. */
553 (((int) ( signed char) program_ptr[-1]) * 256 + \
554 ((int) (unsigned char) program_ptr[-2])))
556 /* Read next int8 from instruction stream; don't advance program_pointer */
557 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
559 /* Read next int16 from instruction stream; don't advance program_pointer */
561 ((((int) ( signed char) program_ptr[1]) * 256) | \
562 ((int) (unsigned char) program_ptr[0]))
564 /* Do relative jumps from the current location.
565 We only do a QUIT if we jump backwards, for efficiency.
566 No infloops without backward jumps! */
567 #define JUMP_RELATIVE(jump) do { \
568 int JR_jump = (jump); \
569 if (JR_jump < 0) QUIT; \
570 program_ptr += JR_jump; \
573 #define JUMP JUMP_RELATIVE (PEEK_INT_2)
574 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
576 #define JUMP_NEXT ((void) (program_ptr += 2))
577 #define JUMPR_NEXT ((void) (program_ptr += 1))
579 /* Push x onto the execution stack. */
580 #define PUSH(x) (*++stack_ptr = (x))
582 /* Pop a value off the execution stack. */
583 #define POP (*stack_ptr--)
585 /* Discard n values from the execution stack. */
586 #define DISCARD(n) (stack_ptr -= (n))
588 /* Get the value which is at the top of the execution stack,
590 #define TOP (*stack_ptr)
592 /* The actual interpreter for byte code.
593 This function has been seriously optimized for performance.
594 Don't change the constructs unless you are willing to do
595 real benchmarking and profiling work -- martin */
599 execute_optimized_program (const Opbyte *program,
601 Lisp_Object *constants_data)
603 /* This function can GC */
604 REGISTER const Opbyte *program_ptr = (Opbyte *) program;
605 REGISTER Lisp_Object *stack_ptr
606 = alloca_array (Lisp_Object, stack_depth + 1);
607 int speccount = specpdl_depth ();
610 #ifdef BYTE_CODE_METER
611 Opcode this_opcode = 0;
615 #ifdef ERROR_CHECK_BYTE_CODE
616 Lisp_Object *stack_beg = stack_ptr;
617 Lisp_Object *stack_end = stack_beg + stack_depth;
620 /* Initialize all the objects on the stack to Qnil,
621 so we can GCPRO the whole stack.
622 The first element of the stack is actually a dummy. */
626 for (i = stack_depth, p = stack_ptr; i--;)
630 GCPRO1 (stack_ptr[1]);
631 gcpro1.nvars = stack_depth;
635 REGISTER Opcode opcode = (Opcode) READ_UINT_1;
636 #ifdef ERROR_CHECK_BYTE_CODE
637 if (stack_ptr > stack_end)
638 invalid_byte_code_error ("byte code stack overflow");
639 if (stack_ptr < stack_beg)
640 invalid_byte_code_error ("byte code stack underflow");
643 #ifdef BYTE_CODE_METER
644 prev_opcode = this_opcode;
645 this_opcode = opcode;
646 meter_code (prev_opcode, this_opcode);
654 if (opcode >= Bconstant)
655 PUSH (constants_data[opcode - Bconstant]);
657 stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode);
665 case Bvarref+5: n = opcode - Bvarref; goto do_varref;
666 case Bvarref+7: n = READ_UINT_2; goto do_varref;
667 case Bvarref+6: n = READ_UINT_1; /* most common */
670 Lisp_Object symbol = constants_data[n];
671 Lisp_Object value = XSYMBOL (symbol)->value;
672 if (SYMBOL_VALUE_MAGIC_P (value))
673 value = Fsymbol_value (symbol);
683 case Bvarset+5: n = opcode - Bvarset; goto do_varset;
684 case Bvarset+7: n = READ_UINT_2; goto do_varset;
685 case Bvarset+6: n = READ_UINT_1; /* most common */
688 Lisp_Object symbol = constants_data[n];
689 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
690 Lisp_Object old_value = symbol_ptr->value;
691 Lisp_Object new_value = POP;
692 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
693 symbol_ptr->value = new_value;
695 Fset (symbol, new_value);
704 case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind;
705 case Bvarbind+7: n = READ_UINT_2; goto do_varbind;
706 case Bvarbind+6: n = READ_UINT_1; /* most common */
709 Lisp_Object symbol = constants_data[n];
710 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
711 Lisp_Object old_value = symbol_ptr->value;
712 Lisp_Object new_value = POP;
713 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
715 specpdl_ptr->symbol = symbol;
716 specpdl_ptr->old_value = old_value;
717 specpdl_ptr->func = 0;
719 specpdl_depth_counter++;
721 symbol_ptr->value = new_value;
724 specbind_magic (symbol, new_value);
736 n = (opcode < Bcall+6 ? opcode - Bcall :
737 opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2);
739 #ifdef BYTE_CODE_METER
740 if (byte_metering_on && SYMBOLP (TOP))
742 Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
744 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
747 TOP = Ffuncall (n + 1, &TOP);
758 UNBIND_TO (specpdl_depth() -
759 (opcode < Bunbind+6 ? opcode-Bunbind :
760 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
782 case Bgotoifnilelsepop:
792 case Bgotoifnonnilelsepop:
821 case BRgotoifnilelsepop:
831 case BRgotoifnonnilelsepop:
843 #ifdef ERROR_CHECK_BYTE_CODE
844 /* Binds and unbinds are supposed to be compiled balanced. */
845 if (specpdl_depth() != speccount)
846 invalid_byte_code_error ("unbalanced specbinding stack");
856 Lisp_Object arg = TOP;
862 PUSH (constants_data[READ_UINT_2]);
866 TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
870 TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
875 /* To unbind back to the beginning of this frame. Not used yet,
876 but will be needed for tail-recursion elimination. */
877 unbind_to (speccount, Qnil);
882 Lisp_Object arg = POP;
883 TOP = Fcar (Fnthcdr (TOP, arg));
888 TOP = SYMBOLP (TOP) ? Qt : Qnil;
892 TOP = CONSP (TOP) ? Qt : Qnil;
896 TOP = STRINGP (TOP) ? Qt : Qnil;
900 TOP = LISTP (TOP) ? Qt : Qnil;
904 TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
908 TOP = INTP (TOP) ? Qt : Qnil;
913 Lisp_Object arg = POP;
914 TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
919 TOP = NILP (TOP) ? Qt : Qnil;
924 Lisp_Object arg = POP;
925 TOP = Fcons (TOP, arg);
930 TOP = Fcons (TOP, Qnil);
942 n = opcode - (Blist1 - 1);
945 Lisp_Object list = Qnil;
947 list = Fcons (TOP, list);
961 n = opcode - (Bconcat2 - 2);
969 TOP = Fconcat (n, &TOP);
979 Lisp_Object arg2 = POP;
980 Lisp_Object arg1 = POP;
981 TOP = Faset (TOP, arg1, arg2);
986 TOP = Fsymbol_value (TOP);
989 case Bsymbol_function:
990 TOP = Fsymbol_function (TOP);
995 Lisp_Object arg = POP;
996 TOP = Fget (TOP, arg, Qnil);
1001 TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
1005 TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
1011 Lisp_Object arg = POP;
1012 TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
1018 Lisp_Object arg = POP;
1019 TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
1025 Lisp_Object arg = POP;
1026 TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
1032 Lisp_Object arg = POP;
1033 TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
1039 Lisp_Object arg = POP;
1040 TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
1046 TOP = bytecode_negate (TOP);
1051 TOP = bytecode_nconc2 (&TOP);
1056 Lisp_Object arg2 = POP;
1057 Lisp_Object arg1 = TOP;
1058 TOP = INTP (arg1) && INTP (arg2) ?
1059 INT_PLUS (arg1, arg2) :
1060 bytecode_arithop (arg1, arg2, opcode);
1066 Lisp_Object arg2 = POP;
1067 Lisp_Object arg1 = TOP;
1068 TOP = INTP (arg1) && INTP (arg2) ?
1069 INT_MINUS (arg1, arg2) :
1070 bytecode_arithop (arg1, arg2, opcode);
1079 Lisp_Object arg = POP;
1080 TOP = bytecode_arithop (TOP, arg, opcode);
1085 PUSH (make_int (BUF_PT (current_buffer)));
1089 TOP = Finsert (1, &TOP);
1095 TOP = Finsert (n, &TOP);
1100 Lisp_Object arg = POP;
1101 TOP = Faref (TOP, arg);
1107 Lisp_Object arg = POP;
1108 TOP = Fmemq (TOP, arg);
1114 Lisp_Object arg = POP;
1115 TOP = Fset (TOP, arg);
1121 Lisp_Object arg = POP;
1122 TOP = Fequal (TOP, arg);
1128 Lisp_Object arg = POP;
1129 TOP = Fnthcdr (TOP, arg);
1135 Lisp_Object arg = POP;
1136 TOP = Felt (TOP, arg);
1142 Lisp_Object arg = POP;
1143 TOP = Fmember (TOP, arg);
1148 TOP = Fgoto_char (TOP, Qnil);
1151 case Bcurrent_buffer:
1154 XSETBUFFER (buffer, current_buffer);
1160 TOP = Fset_buffer (TOP);
1164 PUSH (make_int (BUF_ZV (current_buffer)));
1168 PUSH (make_int (BUF_BEGV (current_buffer)));
1171 case Bskip_chars_forward:
1173 Lisp_Object arg = POP;
1174 TOP = Fskip_chars_forward (TOP, arg, Qnil);
1180 Lisp_Object arg = POP;
1181 TOP = Fassq (TOP, arg);
1187 Lisp_Object arg = POP;
1188 TOP = Fsetcar (TOP, arg);
1194 Lisp_Object arg = POP;
1195 TOP = Fsetcdr (TOP, arg);
1200 TOP = bytecode_nreverse (TOP);
1204 TOP = CONSP (TOP) ? XCAR (TOP) : Qnil;
1208 TOP = CONSP (TOP) ? XCDR (TOP) : Qnil;
1215 /* It makes a worthwhile performance difference (5%) to shunt
1216 lesser-used opcodes off to a subroutine, to keep the switch in
1217 execute_optimized_program small. If you REALLY care about
1218 performance, you want to keep your heavily executed code away from
1219 rarely executed code, to minimize cache misses.
1221 Don't make this function static, since then the compiler might inline it. */
1223 execute_rare_opcode (Lisp_Object *stack_ptr,
1224 const Opbyte *program_ptr,
1230 case Bsave_excursion:
1231 record_unwind_protect (save_excursion_restore,
1232 save_excursion_save ());
1235 case Bsave_window_excursion:
1237 int count = specpdl_depth ();
1238 record_unwind_protect (save_window_excursion_unwind,
1239 Fcurrent_window_configuration (Qnil));
1241 unbind_to (count, Qnil);
1245 case Bsave_restriction:
1246 record_unwind_protect (save_restriction_restore,
1247 save_restriction_save ());
1252 Lisp_Object arg = POP;
1253 TOP = internal_catch (TOP, Feval, arg, 0);
1257 case Bskip_chars_backward:
1259 Lisp_Object arg = POP;
1260 TOP = Fskip_chars_backward (TOP, arg, Qnil);
1264 case Bunwind_protect:
1265 record_unwind_protect (Fprogn, POP);
1268 case Bcondition_case:
1270 Lisp_Object arg2 = POP; /* handlers */
1271 Lisp_Object arg1 = POP; /* bodyform */
1272 TOP = condition_case_3 (arg1, TOP, arg2);
1278 Lisp_Object arg2 = POP;
1279 Lisp_Object arg1 = POP;
1280 TOP = Fset_marker (TOP, arg1, arg2);
1286 Lisp_Object arg = POP;
1287 TOP = Frem (TOP, arg);
1291 case Bmatch_beginning:
1292 TOP = Fmatch_beginning (TOP);
1296 TOP = Fmatch_end (TOP);
1300 TOP = Fupcase (TOP, Qnil);
1304 TOP = Fdowncase (TOP, Qnil);
1309 Lisp_Object arg = POP;
1310 TOP = Ffset (TOP, arg);
1316 Lisp_Object arg = POP;
1317 TOP = Fstring_equal (TOP, arg);
1323 Lisp_Object arg = POP;
1324 TOP = Fstring_lessp (TOP, arg);
1330 Lisp_Object arg2 = POP;
1331 Lisp_Object arg1 = POP;
1332 TOP = Fsubstring (TOP, arg1, arg2);
1336 case Bcurrent_column:
1337 PUSH (make_int (current_column (current_buffer)));
1341 TOP = Fchar_after (TOP, Qnil);
1345 TOP = Findent_to (TOP, Qnil, Qnil);
1349 PUSH (Fwiden (Qnil));
1352 case Bfollowing_char:
1353 PUSH (Ffollowing_char (Qnil));
1356 case Bpreceding_char:
1357 PUSH (Fpreceding_char (Qnil));
1361 PUSH (Feolp (Qnil));
1365 PUSH (Feobp (Qnil));
1369 PUSH (Fbolp (Qnil));
1373 PUSH (Fbobp (Qnil));
1376 case Bsave_current_buffer:
1377 record_unwind_protect (save_current_buffer_restore,
1378 Fcurrent_buffer ());
1381 case Binteractive_p:
1382 PUSH (Finteractive_p ());
1386 TOP = Fforward_char (TOP, Qnil);
1390 TOP = Fforward_word (TOP, Qnil);
1394 TOP = Fforward_line (TOP, Qnil);
1398 TOP = Fchar_syntax (TOP, Qnil);
1401 case Bbuffer_substring:
1403 Lisp_Object arg = POP;
1404 TOP = Fbuffer_substring (TOP, arg, Qnil);
1408 case Bdelete_region:
1410 Lisp_Object arg = POP;
1411 TOP = Fdelete_region (TOP, arg, Qnil);
1415 case Bnarrow_to_region:
1417 Lisp_Object arg = POP;
1418 TOP = Fnarrow_to_region (TOP, arg, Qnil);
1423 TOP = Fend_of_line (TOP, Qnil);
1426 case Btemp_output_buffer_setup:
1427 temp_output_buffer_setup (TOP);
1428 TOP = Vstandard_output;
1431 case Btemp_output_buffer_show:
1433 Lisp_Object arg = POP;
1434 temp_output_buffer_show (TOP, Qnil);
1437 /* pop binding of standard-output */
1438 unbind_to (specpdl_depth() - 1, Qnil);
1444 Lisp_Object arg = POP;
1445 TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
1451 Lisp_Object arg = POP;
1452 TOP = Fold_memq (TOP, arg);
1458 Lisp_Object arg = POP;
1459 TOP = Fold_equal (TOP, arg);
1465 Lisp_Object arg = POP;
1466 TOP = Fold_member (TOP, arg);
1472 Lisp_Object arg = POP;
1473 TOP = Fold_assq (TOP, arg);
1486 invalid_byte_code_error (char *error_message, ...)
1490 char *buf = alloca_array (char, strlen (error_message) + 128);
1492 sprintf (buf, "%s", error_message);
1493 va_start (args, error_message);
1494 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (buf), Qnil, -1,
1498 signal_error (Qinvalid_byte_code, list1 (obj));
1501 /* Check for valid opcodes. Change this when adding new opcodes. */
1503 check_opcode (Opcode opcode)
1505 if ((opcode < Bvarref) ||
1507 (opcode > Bassq && opcode < Bconstant))
1508 invalid_byte_code_error
1509 ("invalid opcode %d in instruction stream", opcode);
1512 /* Check that IDX is a valid offset into the `constants' vector */
1514 check_constants_index (int idx, Lisp_Object constants)
1516 if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
1517 invalid_byte_code_error
1518 ("reference %d to constants array out of range 0, %d",
1519 idx, XVECTOR_LENGTH (constants) - 1);
1522 /* Get next character from Lisp instructions string. */
1523 #define READ_INSTRUCTION_CHAR(lvalue) do { \
1524 (lvalue) = charptr_emchar (ptr); \
1525 INC_CHARPTR (ptr); \
1526 *icounts_ptr++ = program_ptr - program; \
1527 if (lvalue > UCHAR_MAX) \
1528 invalid_byte_code_error \
1529 ("Invalid character %c in byte code string"); \
1532 /* Get opcode from Lisp instructions string. */
1533 #define READ_OPCODE do { \
1535 READ_INSTRUCTION_CHAR (c); \
1536 opcode = (Opcode) c; \
1539 /* Get next operand, a uint8, from Lisp instructions string. */
1540 #define READ_OPERAND_1 do { \
1541 READ_INSTRUCTION_CHAR (arg); \
1545 /* Get next operand, a uint16, from Lisp instructions string. */
1546 #define READ_OPERAND_2 do { \
1547 unsigned int arg1, arg2; \
1548 READ_INSTRUCTION_CHAR (arg1); \
1549 READ_INSTRUCTION_CHAR (arg2); \
1550 arg = arg1 + (arg2 << 8); \
1554 /* Write 1 byte to PTR, incrementing PTR */
1555 #define WRITE_INT8(value, ptr) do { \
1556 *((ptr)++) = (value); \
1559 /* Write 2 bytes to PTR, incrementing PTR */
1560 #define WRITE_INT16(value, ptr) do { \
1561 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \
1562 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \
1565 /* We've changed our minds about the opcode we've already written. */
1566 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
1568 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
1569 #define WRITE_NARGS(base_opcode) do { \
1572 REWRITE_OPCODE (base_opcode + arg); \
1574 else if (arg <= UCHAR_MAX) \
1576 REWRITE_OPCODE (base_opcode + 6); \
1577 WRITE_INT8 (arg, program_ptr); \
1581 REWRITE_OPCODE (base_opcode + 7); \
1582 WRITE_INT16 (arg, program_ptr); \
1586 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
1587 #define WRITE_CONSTANT do { \
1588 check_constants_index(arg, constants); \
1589 if (arg <= UCHAR_MAX - Bconstant) \
1591 REWRITE_OPCODE (Bconstant + arg); \
1595 REWRITE_OPCODE (Bconstant2); \
1596 WRITE_INT16 (arg, program_ptr); \
1600 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
1602 /* Compile byte code instructions into free space provided by caller, with
1603 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
1604 Returns length of compiled code. */
1606 optimize_byte_code (/* in */
1607 Lisp_Object instructions,
1608 Lisp_Object constants,
1610 Opbyte * const program,
1611 int * const program_length,
1612 int * const varbind_count)
1614 size_t instructions_length = XSTRING_LENGTH (instructions);
1615 size_t comfy_size = 2 * instructions_length;
1617 int * const icounts = alloca_array (int, comfy_size);
1618 int * icounts_ptr = icounts;
1620 /* We maintain a table of jumps in the source code. */
1626 struct jump * const jumps = alloca_array (struct jump, comfy_size);
1627 struct jump *jumps_ptr = jumps;
1629 Opbyte *program_ptr = program;
1631 const Bufbyte *ptr = XSTRING_DATA (instructions);
1632 const Bufbyte * const end = ptr + instructions_length;
1648 case Bvarref+7: READ_OPERAND_2; goto do_varref;
1649 case Bvarref+6: READ_OPERAND_1; goto do_varref;
1650 case Bvarref: case Bvarref+1: case Bvarref+2:
1651 case Bvarref+3: case Bvarref+4: case Bvarref+5:
1652 arg = opcode - Bvarref;
1654 check_constants_index (arg, constants);
1655 val = XVECTOR_DATA (constants) [arg];
1657 invalid_byte_code_error ("variable reference to non-symbol %S", val);
1658 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1659 invalid_byte_code_error ("variable reference to constant symbol %s",
1660 string_data (XSYMBOL (val)->name));
1661 WRITE_NARGS (Bvarref);
1664 case Bvarset+7: READ_OPERAND_2; goto do_varset;
1665 case Bvarset+6: READ_OPERAND_1; goto do_varset;
1666 case Bvarset: case Bvarset+1: case Bvarset+2:
1667 case Bvarset+3: case Bvarset+4: case Bvarset+5:
1668 arg = opcode - Bvarset;
1670 check_constants_index (arg, constants);
1671 val = XVECTOR_DATA (constants) [arg];
1673 invalid_byte_code_error ("attempt to set non-symbol %S", val);
1674 if (EQ (val, Qnil) || EQ (val, Qt))
1675 invalid_byte_code_error ("attempt to set constant symbol %s",
1676 string_data (XSYMBOL (val)->name));
1677 /* Ignore assignments to keywords by converting to Bdiscard.
1678 For backward compatibility only - we'd like to make this an error. */
1679 if (SYMBOL_IS_KEYWORD (val))
1680 REWRITE_OPCODE (Bdiscard);
1682 WRITE_NARGS (Bvarset);
1685 case Bvarbind+7: READ_OPERAND_2; goto do_varbind;
1686 case Bvarbind+6: READ_OPERAND_1; goto do_varbind;
1687 case Bvarbind: case Bvarbind+1: case Bvarbind+2:
1688 case Bvarbind+3: case Bvarbind+4: case Bvarbind+5:
1689 arg = opcode - Bvarbind;
1692 check_constants_index (arg, constants);
1693 val = XVECTOR_DATA (constants) [arg];
1695 invalid_byte_code_error ("attempt to let-bind non-symbol %S", val);
1696 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1697 invalid_byte_code_error ("attempt to let-bind constant symbol %s",
1698 string_data (XSYMBOL (val)->name));
1699 WRITE_NARGS (Bvarbind);
1702 case Bcall+7: READ_OPERAND_2; goto do_call;
1703 case Bcall+6: READ_OPERAND_1; goto do_call;
1704 case Bcall: case Bcall+1: case Bcall+2:
1705 case Bcall+3: case Bcall+4: case Bcall+5:
1706 arg = opcode - Bcall;
1708 WRITE_NARGS (Bcall);
1711 case Bunbind+7: READ_OPERAND_2; goto do_unbind;
1712 case Bunbind+6: READ_OPERAND_1; goto do_unbind;
1713 case Bunbind: case Bunbind+1: case Bunbind+2:
1714 case Bunbind+3: case Bunbind+4: case Bunbind+5:
1715 arg = opcode - Bunbind;
1717 WRITE_NARGS (Bunbind);
1723 case Bgotoifnilelsepop:
1724 case Bgotoifnonnilelsepop:
1726 /* Make program_ptr-relative */
1727 arg += icounts - (icounts_ptr - argsize);
1732 case BRgotoifnonnil:
1733 case BRgotoifnilelsepop:
1734 case BRgotoifnonnilelsepop:
1736 /* Make program_ptr-relative */
1739 /* Record program-relative goto addresses in `jumps' table */
1740 jumps_ptr->from = icounts_ptr - icounts - argsize;
1741 jumps_ptr->to = jumps_ptr->from + arg;
1743 if (arg >= -1 && arg <= argsize)
1744 invalid_byte_code_error
1745 ("goto instruction is its own target");
1746 if (arg <= SCHAR_MIN ||
1750 REWRITE_OPCODE (opcode + Bgoto - BRgoto);
1751 WRITE_INT16 (arg, program_ptr);
1756 REWRITE_OPCODE (opcode + BRgoto - Bgoto);
1757 WRITE_INT8 (arg, program_ptr);
1770 WRITE_INT8 (arg, program_ptr);
1774 if (opcode < Bconstant)
1775 check_opcode (opcode);
1778 arg = opcode - Bconstant;
1785 /* Fix up jumps table to refer to NEW offsets. */
1788 for (j = jumps; j < jumps_ptr; j++)
1790 #ifdef ERROR_CHECK_BYTE_CODE
1791 assert (j->from < icounts_ptr - icounts);
1792 assert (j->to < icounts_ptr - icounts);
1794 j->from = icounts[j->from];
1795 j->to = icounts[j->to];
1796 #ifdef ERROR_CHECK_BYTE_CODE
1797 assert (j->from < program_ptr - program);
1798 assert (j->to < program_ptr - program);
1799 check_opcode ((Opcode) (program[j->from-1]));
1801 check_opcode ((Opcode) (program[j->to]));
1805 /* Fixup jumps in byte-code until no more fixups needed */
1807 int more_fixups_needed = 1;
1809 while (more_fixups_needed)
1812 more_fixups_needed = 0;
1813 for (j = jumps; j < jumps_ptr; j++)
1817 int jump = to - from;
1818 Opbyte *p = program + from;
1819 Opcode opcode = (Opcode) p[-1];
1820 if (!more_fixups_needed)
1821 check_opcode ((Opcode) p[jump]);
1822 assert (to >= 0 && program + to < program_ptr);
1828 case Bgotoifnilelsepop:
1829 case Bgotoifnonnilelsepop:
1830 WRITE_INT16 (jump, p);
1835 case BRgotoifnonnil:
1836 case BRgotoifnilelsepop:
1837 case BRgotoifnonnilelsepop:
1838 if (jump > SCHAR_MIN &&
1841 WRITE_INT8 (jump, p);
1846 for (jj = jumps; jj < jumps_ptr; jj++)
1848 assert (jj->from < program_ptr - program);
1849 assert (jj->to < program_ptr - program);
1850 if (jj->from > from) jj->from++;
1851 if (jj->to > from) jj->to++;
1853 p[-1] += Bgoto - BRgoto;
1854 more_fixups_needed = 1;
1855 memmove (p+1, p, program_ptr++ - p);
1856 WRITE_INT16 (jump, p);
1868 /* *program_ptr++ = 0; */
1869 *program_length = program_ptr - program;
1872 /* Optimize the byte code and store the optimized program, only
1873 understood by bytecode.c, in an opaque object in the
1874 instructions slot of the Compiled_Function object. */
1876 optimize_compiled_function (Lisp_Object compiled_function)
1878 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
1883 /* If we have not actually read the bytecode string
1884 and constants vector yet, fetch them from the file. */
1885 if (CONSP (f->instructions))
1886 Ffetch_bytecode (compiled_function);
1888 if (STRINGP (f->instructions))
1890 /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1891 which would be slightly more `proper' */
1892 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
1893 optimize_byte_code (f->instructions, f->constants,
1894 program, &program_length, &varbind_count);
1895 f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
1897 make_opaque (program, program_length * sizeof (Opbyte));
1900 assert (OPAQUEP (f->instructions));
1903 /************************************************************************/
1904 /* The compiled-function object type */
1905 /************************************************************************/
1907 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
1910 /* This function can GC */
1911 Lisp_Compiled_Function *f =
1912 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
1913 int docp = f->flags.documentationp;
1914 int intp = f->flags.interactivep;
1915 struct gcpro gcpro1, gcpro2;
1917 GCPRO2 (obj, printcharfun);
1919 write_c_string (print_readably ? "#[" : "#<compiled-function ", printcharfun);
1920 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1921 if (!print_readably)
1923 Lisp_Object ann = compiled_function_annotation (f);
1926 write_c_string ("(from ", printcharfun);
1927 print_internal (ann, printcharfun, 1);
1928 write_c_string (") ", printcharfun);
1931 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1932 /* COMPILED_ARGLIST = 0 */
1933 print_internal (compiled_function_arglist (f), printcharfun, escapeflag);
1935 /* COMPILED_INSTRUCTIONS = 1 */
1936 write_c_string (" ", printcharfun);
1938 struct gcpro ngcpro1;
1939 Lisp_Object instructions = compiled_function_instructions (f);
1940 NGCPRO1 (instructions);
1941 if (STRINGP (instructions) && !print_readably)
1943 /* We don't usually want to see that junk in the bytecode. */
1944 sprintf (buf, "\"...(%ld)\"",
1945 (long) XSTRING_CHAR_LENGTH (instructions));
1946 write_c_string (buf, printcharfun);
1949 print_internal (instructions, printcharfun, escapeflag);
1953 /* COMPILED_CONSTANTS = 2 */
1954 write_c_string (" ", printcharfun);
1955 print_internal (compiled_function_constants (f), printcharfun, escapeflag);
1957 /* COMPILED_STACK_DEPTH = 3 */
1958 sprintf (buf, " %d", compiled_function_stack_depth (f));
1959 write_c_string (buf, printcharfun);
1961 /* COMPILED_DOC_STRING = 4 */
1964 write_c_string (" ", printcharfun);
1965 print_internal (compiled_function_documentation (f), printcharfun,
1969 /* COMPILED_INTERACTIVE = 5 */
1972 write_c_string (" ", printcharfun);
1973 print_internal (compiled_function_interactive (f), printcharfun,
1978 write_c_string (print_readably ? "]" : ">", printcharfun);
1983 mark_compiled_function (Lisp_Object obj)
1985 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1987 mark_object (f->instructions);
1988 mark_object (f->arglist);
1989 mark_object (f->doc_and_interactive);
1990 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1991 mark_object (f->annotated);
1993 /* tail-recurse on constants */
1994 return f->constants;
1998 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2000 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1);
2001 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
2003 (f1->flags.documentationp == f2->flags.documentationp &&
2004 f1->flags.interactivep == f2->flags.interactivep &&
2005 f1->flags.domainp == f2->flags.domainp && /* I18N3 */
2006 internal_equal (compiled_function_instructions (f1),
2007 compiled_function_instructions (f2), depth + 1) &&
2008 internal_equal (f1->constants, f2->constants, depth + 1) &&
2009 internal_equal (f1->arglist, f2->arglist, depth + 1) &&
2010 internal_equal (f1->doc_and_interactive,
2011 f2->doc_and_interactive, depth + 1));
2014 static unsigned long
2015 compiled_function_hash (Lisp_Object obj, int depth)
2017 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
2018 return HASH3 ((f->flags.documentationp << 2) +
2019 (f->flags.interactivep << 1) +
2021 internal_hash (f->instructions, depth + 1),
2022 internal_hash (f->constants, depth + 1));
2025 static const struct lrecord_description compiled_function_description[] = {
2026 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
2027 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
2028 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
2029 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
2030 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2031 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
2036 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
2037 mark_compiled_function,
2038 print_compiled_function, 0,
2039 compiled_function_equal,
2040 compiled_function_hash,
2041 compiled_function_description,
2042 Lisp_Compiled_Function);
2044 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
2045 Return t if OBJECT is a byte-compiled function object.
2049 return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
2052 /************************************************************************/
2053 /* compiled-function object accessor functions */
2054 /************************************************************************/
2057 compiled_function_arglist (Lisp_Compiled_Function *f)
2063 compiled_function_instructions (Lisp_Compiled_Function *f)
2065 if (! OPAQUEP (f->instructions))
2066 return f->instructions;
2069 /* Invert action performed by optimize_byte_code() */
2070 Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2072 Bufbyte * const buffer =
2073 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2074 Bufbyte *bp = buffer;
2076 const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
2077 const Opbyte *program_ptr = program;
2078 const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);
2080 while (program_ptr < program_end)
2082 Opcode opcode = (Opcode) READ_UINT_1;
2083 bp += set_charptr_emchar (bp, opcode);
2092 bp += set_charptr_emchar (bp, READ_UINT_1);
2093 bp += set_charptr_emchar (bp, READ_UINT_1);
2104 bp += set_charptr_emchar (bp, READ_UINT_1);
2110 case Bgotoifnilelsepop:
2111 case Bgotoifnonnilelsepop:
2113 int jump = READ_INT_2;
2115 Opbyte *buf2p = buf2;
2116 /* Convert back to program-relative address */
2117 WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
2118 bp += set_charptr_emchar (bp, buf2[0]);
2119 bp += set_charptr_emchar (bp, buf2[1]);
2125 case BRgotoifnonnil:
2126 case BRgotoifnilelsepop:
2127 case BRgotoifnonnilelsepop:
2128 bp += set_charptr_emchar (bp, READ_INT_1 + 127);
2135 return make_string (buffer, bp - buffer);
2140 compiled_function_constants (Lisp_Compiled_Function *f)
2142 return f->constants;
2146 compiled_function_stack_depth (Lisp_Compiled_Function *f)
2148 return f->stack_depth;
2151 /* The compiled_function->doc_and_interactive slot uses the minimal
2152 number of conses, based on compiled_function->flags; it may take
2153 any of the following forms:
2160 (interactive . domain)
2161 (doc . (interactive . domain))
2164 /* Caller must check flags.interactivep first */
2166 compiled_function_interactive (Lisp_Compiled_Function *f)
2168 assert (f->flags.interactivep);
2169 if (f->flags.documentationp && f->flags.domainp)
2170 return XCAR (XCDR (f->doc_and_interactive));
2171 else if (f->flags.documentationp)
2172 return XCDR (f->doc_and_interactive);
2173 else if (f->flags.domainp)
2174 return XCAR (f->doc_and_interactive);
2176 return f->doc_and_interactive;
2179 /* Caller need not check flags.documentationp first */
2181 compiled_function_documentation (Lisp_Compiled_Function *f)
2183 if (! f->flags.documentationp)
2185 else if (f->flags.interactivep && f->flags.domainp)
2186 return XCAR (f->doc_and_interactive);
2187 else if (f->flags.interactivep)
2188 return XCAR (f->doc_and_interactive);
2189 else if (f->flags.domainp)
2190 return XCAR (f->doc_and_interactive);
2192 return f->doc_and_interactive;
2195 /* Caller need not check flags.domainp first */
2197 compiled_function_domain (Lisp_Compiled_Function *f)
2199 if (! f->flags.domainp)
2201 else if (f->flags.documentationp && f->flags.interactivep)
2202 return XCDR (XCDR (f->doc_and_interactive));
2203 else if (f->flags.documentationp)
2204 return XCDR (f->doc_and_interactive);
2205 else if (f->flags.interactivep)
2206 return XCDR (f->doc_and_interactive);
2208 return f->doc_and_interactive;
2211 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2214 compiled_function_annotation (Lisp_Compiled_Function *f)
2216 return f->annotated;
2221 /* used only by Snarf-documentation; there must be doc already. */
2223 set_compiled_function_documentation (Lisp_Compiled_Function *f,
2224 Lisp_Object new_doc)
2226 assert (f->flags.documentationp);
2227 assert (INTP (new_doc) || STRINGP (new_doc));
2229 if (f->flags.interactivep && f->flags.domainp)
2230 XCAR (f->doc_and_interactive) = new_doc;
2231 else if (f->flags.interactivep)
2232 XCAR (f->doc_and_interactive) = new_doc;
2233 else if (f->flags.domainp)
2234 XCAR (f->doc_and_interactive) = new_doc;
2236 f->doc_and_interactive = new_doc;
2240 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2241 Return the argument list of the compiled-function object FUNCTION.
2245 CHECK_COMPILED_FUNCTION (function);
2246 return compiled_function_arglist (XCOMPILED_FUNCTION (function));
2249 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
2250 Return the byte-opcode string of the compiled-function object FUNCTION.
2254 CHECK_COMPILED_FUNCTION (function);
2255 return compiled_function_instructions (XCOMPILED_FUNCTION (function));
2258 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
2259 Return the constants vector of the compiled-function object FUNCTION.
2263 CHECK_COMPILED_FUNCTION (function);
2264 return compiled_function_constants (XCOMPILED_FUNCTION (function));
2267 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2268 Return the max stack depth of the compiled-function object FUNCTION.
2272 CHECK_COMPILED_FUNCTION (function);
2273 return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
2276 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
2277 Return the doc string of the compiled-function object FUNCTION, if available.
2278 Functions that had their doc strings snarfed into the DOC file will have
2279 an integer returned instead of a string.
2283 CHECK_COMPILED_FUNCTION (function);
2284 return compiled_function_documentation (XCOMPILED_FUNCTION (function));
2287 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2288 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2289 If non-nil, the return value will be a list whose first element is
2290 `interactive' and whose second element is the interactive spec.
2294 CHECK_COMPILED_FUNCTION (function);
2295 return XCOMPILED_FUNCTION (function)->flags.interactivep
2296 ? list2 (Qinteractive,
2297 compiled_function_interactive (XCOMPILED_FUNCTION (function)))
2301 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2303 /* Remove the `xx' if you wish to restore this feature */
2304 xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2305 Return the annotation of the compiled-function object FUNCTION, or nil.
2306 The annotation is a piece of information indicating where this
2307 compiled-function object came from. Generally this will be
2308 a symbol naming a function; or a string naming a file, if the
2309 compiled-function object was not defined in a function; or nil,
2310 if the compiled-function object was not created as a result of
2315 CHECK_COMPILED_FUNCTION (function);
2316 return compiled_function_annotation (XCOMPILED_FUNCTION (function));
2319 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2321 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
2322 Return the domain of the compiled-function object FUNCTION, or nil.
2323 This is only meaningful if I18N3 was enabled when emacs was compiled.
2327 CHECK_COMPILED_FUNCTION (function);
2328 return XCOMPILED_FUNCTION (function)->flags.domainp
2329 ? compiled_function_domain (XCOMPILED_FUNCTION (function))
2335 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
2336 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2340 Lisp_Compiled_Function *f;
2341 CHECK_COMPILED_FUNCTION (function);
2342 f = XCOMPILED_FUNCTION (function);
2344 if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
2347 if (CONSP (f->instructions))
2349 Lisp_Object tem = read_doc_string (f->instructions);
2351 signal_simple_error ("Invalid lazy-loaded byte code", tem);
2352 /* v18 or v19 bytecode file. Need to Ebolify. */
2353 if (f->flags.ebolified && VECTORP (XCDR (tem)))
2354 ebolify_bytecode_constants (XCDR (tem));
2355 f->instructions = XCAR (tem);
2356 f->constants = XCDR (tem);
2360 return Qnil; /* not reached */
2363 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
2364 Convert compiled function FUNCTION into an optimized internal form.
2368 Lisp_Compiled_Function *f;
2369 CHECK_COMPILED_FUNCTION (function);
2370 f = XCOMPILED_FUNCTION (function);
2372 if (OPAQUEP (f->instructions)) /* Already optimized? */
2375 optimize_compiled_function (function);
2379 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
2380 Function used internally in byte-compiled code.
2381 First argument INSTRUCTIONS is a string of byte code.
2382 Second argument CONSTANTS is a vector of constants.
2383 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2384 If STACK-DEPTH is incorrect, Emacs may crash.
2386 (instructions, constants, stack_depth))
2388 /* This function can GC */
2393 CHECK_STRING (instructions);
2394 CHECK_VECTOR (constants);
2395 CHECK_NATNUM (stack_depth);
2397 /* Optimize the `instructions' string, just like when executing a
2398 regular compiled function, but don't save it for later since this is
2399 likely to only be executed once. */
2400 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
2401 optimize_byte_code (instructions, constants, program,
2402 &program_length, &varbind_count);
2403 SPECPDL_RESERVE (varbind_count);
2404 return execute_optimized_program (program,
2406 XVECTOR_DATA (constants));
2411 syms_of_bytecode (void)
2413 INIT_LRECORD_IMPLEMENTATION (compiled_function);
2415 deferror (&Qinvalid_byte_code, "invalid-byte-code",
2416 "Invalid byte code", Qerror);
2417 defsymbol (&Qbyte_code, "byte-code");
2418 defsymbol (&Qcompiled_functionp, "compiled-function-p");
2420 DEFSUBR (Fbyte_code);
2421 DEFSUBR (Ffetch_bytecode);
2422 DEFSUBR (Foptimize_compiled_function);
2424 DEFSUBR (Fcompiled_function_p);
2425 DEFSUBR (Fcompiled_function_instructions);
2426 DEFSUBR (Fcompiled_function_constants);
2427 DEFSUBR (Fcompiled_function_stack_depth);
2428 DEFSUBR (Fcompiled_function_arglist);
2429 DEFSUBR (Fcompiled_function_interactive);
2430 DEFSUBR (Fcompiled_function_doc_string);
2431 DEFSUBR (Fcompiled_function_domain);
2432 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2433 DEFSUBR (Fcompiled_function_annotation);
2436 #ifdef BYTE_CODE_METER
2437 defsymbol (&Qbyte_code_meter, "byte-code-meter");
2442 vars_of_bytecode (void)
2444 #ifdef BYTE_CODE_METER
2446 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
2447 A vector of vectors which holds a histogram of byte code usage.
2448 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2449 opcode CODE has been executed.
2450 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2451 indicates how many times the byte opcodes CODE1 and CODE2 have been
2452 executed in succession.
2454 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /*
2455 If non-nil, keep profiling information on byte code usage.
2456 The variable `byte-code-meter' indicates how often each byte opcode is used.
2457 If a symbol has a property named `byte-code-meter' whose value is an
2458 integer, it is incremented each time that symbol's function is called.
2461 byte_metering_on = 0;
2462 Vbyte_code_meter = make_vector (256, Qzero);
2466 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
2468 #endif /* BYTE_CODE_METER */