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"
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 return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
534 /* Read next uint8 from the instruction stream. */
535 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
537 /* Read next uint16 from the instruction stream. */
538 #define READ_UINT_2 \
540 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \
541 ((unsigned int) (unsigned char) program_ptr[-2])))
543 /* Read next int8 from the instruction stream. */
544 #define READ_INT_1 ((int) (signed char) *program_ptr++)
546 /* Read next int16 from the instruction stream. */
549 (((int) ( signed char) program_ptr[-1]) * 256 + \
550 ((int) (unsigned char) program_ptr[-2])))
552 /* Read next int8 from instruction stream; don't advance program_pointer */
553 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
555 /* Read next int16 from instruction stream; don't advance program_pointer */
557 ((((int) ( signed char) program_ptr[1]) * 256) | \
558 ((int) (unsigned char) program_ptr[0]))
560 /* Do relative jumps from the current location.
561 We only do a QUIT if we jump backwards, for efficiency.
562 No infloops without backward jumps! */
563 #define JUMP_RELATIVE(jump) do { \
564 int JR_jump = (jump); \
565 if (JR_jump < 0) QUIT; \
566 program_ptr += JR_jump; \
569 #define JUMP JUMP_RELATIVE (PEEK_INT_2)
570 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
572 #define JUMP_NEXT ((void) (program_ptr += 2))
573 #define JUMPR_NEXT ((void) (program_ptr += 1))
575 /* Push x onto the execution stack. */
576 #define PUSH(x) (*++stack_ptr = (x))
578 /* Pop a value off the execution stack. */
579 #define POP (*stack_ptr--)
581 /* Discard n values from the execution stack. */
582 #define DISCARD(n) (stack_ptr -= (n))
584 /* Get the value which is at the top of the execution stack,
586 #define TOP (*stack_ptr)
588 /* The actual interpreter for byte code.
589 This function has been seriously optimized for performance.
590 Don't change the constructs unless you are willing to do
591 real benchmarking and profiling work -- martin */
595 execute_optimized_program (CONST Opbyte *program,
597 Lisp_Object *constants_data)
599 /* This function can GC */
600 REGISTER CONST Opbyte *program_ptr = (Opbyte *) program;
601 REGISTER Lisp_Object *stack_ptr
602 = alloca_array (Lisp_Object, stack_depth + 1);
603 int speccount = specpdl_depth ();
606 #ifdef BYTE_CODE_METER
607 Opcode this_opcode = 0;
611 #ifdef ERROR_CHECK_BYTE_CODE
612 Lisp_Object *stack_beg = stack_ptr;
613 Lisp_Object *stack_end = stack_beg + stack_depth;
616 /* Initialize all the objects on the stack to Qnil,
617 so we can GCPRO the whole stack.
618 The first element of the stack is actually a dummy. */
622 for (i = stack_depth, p = stack_ptr; i--;)
626 GCPRO1 (stack_ptr[1]);
627 gcpro1.nvars = stack_depth;
631 REGISTER Opcode opcode = (Opcode) READ_UINT_1;
632 #ifdef ERROR_CHECK_BYTE_CODE
633 if (stack_ptr > stack_end)
634 invalid_byte_code_error ("byte code stack overflow");
635 if (stack_ptr < stack_beg)
636 invalid_byte_code_error ("byte code stack underflow");
639 #ifdef BYTE_CODE_METER
640 prev_opcode = this_opcode;
641 this_opcode = opcode;
642 meter_code (prev_opcode, this_opcode);
650 if (opcode >= Bconstant)
651 PUSH (constants_data[opcode - Bconstant]);
653 stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode);
661 case Bvarref+5: n = opcode - Bvarref; goto do_varref;
662 case Bvarref+7: n = READ_UINT_2; goto do_varref;
663 case Bvarref+6: n = READ_UINT_1; /* most common */
666 Lisp_Object symbol = constants_data[n];
667 Lisp_Object value = XSYMBOL (symbol)->value;
668 if (SYMBOL_VALUE_MAGIC_P (value))
669 value = Fsymbol_value (symbol);
679 case Bvarset+5: n = opcode - Bvarset; goto do_varset;
680 case Bvarset+7: n = READ_UINT_2; goto do_varset;
681 case Bvarset+6: n = READ_UINT_1; /* most common */
684 Lisp_Object symbol = constants_data[n];
685 struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
686 Lisp_Object old_value = symbol_ptr->value;
687 Lisp_Object new_value = POP;
688 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
689 symbol_ptr->value = new_value;
691 Fset (symbol, new_value);
700 case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind;
701 case Bvarbind+7: n = READ_UINT_2; goto do_varbind;
702 case Bvarbind+6: n = READ_UINT_1; /* most common */
705 Lisp_Object symbol = constants_data[n];
706 struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
707 Lisp_Object old_value = symbol_ptr->value;
708 Lisp_Object new_value = POP;
709 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
711 specpdl_ptr->symbol = symbol;
712 specpdl_ptr->old_value = old_value;
713 specpdl_ptr->func = 0;
715 specpdl_depth_counter++;
717 symbol_ptr->value = new_value;
720 specbind_magic (symbol, new_value);
732 n = (opcode < Bcall+6 ? opcode - Bcall :
733 opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2);
735 #ifdef BYTE_CODE_METER
736 if (byte_metering_on && SYMBOLP (TOP))
738 Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
740 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
743 TOP = Ffuncall (n + 1, &TOP);
754 UNBIND_TO (specpdl_depth() -
755 (opcode < Bunbind+6 ? opcode-Bunbind :
756 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
778 case Bgotoifnilelsepop:
788 case Bgotoifnonnilelsepop:
817 case BRgotoifnilelsepop:
827 case BRgotoifnonnilelsepop:
839 #ifdef ERROR_CHECK_BYTE_CODE
840 /* Binds and unbinds are supposed to be compiled balanced. */
841 if (specpdl_depth() != speccount)
842 invalid_byte_code_error ("unbalanced specbinding stack");
852 Lisp_Object arg = TOP;
858 PUSH (constants_data[READ_UINT_2]);
862 TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
866 TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
871 /* To unbind back to the beginning of this frame. Not used yet,
872 but will be needed for tail-recursion elimination. */
873 unbind_to (speccount, Qnil);
878 Lisp_Object arg = POP;
879 TOP = Fcar (Fnthcdr (TOP, arg));
884 TOP = SYMBOLP (TOP) ? Qt : Qnil;
888 TOP = CONSP (TOP) ? Qt : Qnil;
892 TOP = STRINGP (TOP) ? Qt : Qnil;
896 TOP = LISTP (TOP) ? Qt : Qnil;
900 TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
904 TOP = INTP (TOP) ? Qt : Qnil;
909 Lisp_Object arg = POP;
910 TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
915 TOP = NILP (TOP) ? Qt : Qnil;
920 Lisp_Object arg = POP;
921 TOP = Fcons (TOP, arg);
926 TOP = Fcons (TOP, Qnil);
938 n = opcode - (Blist1 - 1);
941 Lisp_Object list = Qnil;
943 list = Fcons (TOP, list);
957 n = opcode - (Bconcat2 - 2);
965 TOP = Fconcat (n, &TOP);
975 Lisp_Object arg2 = POP;
976 Lisp_Object arg1 = POP;
977 TOP = Faset (TOP, arg1, arg2);
982 TOP = Fsymbol_value (TOP);
985 case Bsymbol_function:
986 TOP = Fsymbol_function (TOP);
991 Lisp_Object arg = POP;
992 TOP = Fget (TOP, arg, Qnil);
997 TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
1001 TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
1007 Lisp_Object arg = POP;
1008 TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
1014 Lisp_Object arg = POP;
1015 TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
1021 Lisp_Object arg = POP;
1022 TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
1028 Lisp_Object arg = POP;
1029 TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
1035 Lisp_Object arg = POP;
1036 TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
1042 TOP = bytecode_negate (TOP);
1047 TOP = bytecode_nconc2 (&TOP);
1052 Lisp_Object arg2 = POP;
1053 Lisp_Object arg1 = TOP;
1054 TOP = INTP (arg1) && INTP (arg2) ?
1055 INT_PLUS (arg1, arg2) :
1056 bytecode_arithop (arg1, arg2, opcode);
1062 Lisp_Object arg2 = POP;
1063 Lisp_Object arg1 = TOP;
1064 TOP = INTP (arg1) && INTP (arg2) ?
1065 INT_MINUS (arg1, arg2) :
1066 bytecode_arithop (arg1, arg2, opcode);
1075 Lisp_Object arg = POP;
1076 TOP = bytecode_arithop (TOP, arg, opcode);
1081 PUSH (make_int (BUF_PT (current_buffer)));
1085 TOP = Finsert (1, &TOP);
1091 TOP = Finsert (n, &TOP);
1096 Lisp_Object arg = POP;
1097 TOP = Faref (TOP, arg);
1103 Lisp_Object arg = POP;
1104 TOP = Fmemq (TOP, arg);
1110 Lisp_Object arg = POP;
1111 TOP = Fset (TOP, arg);
1117 Lisp_Object arg = POP;
1118 TOP = Fequal (TOP, arg);
1124 Lisp_Object arg = POP;
1125 TOP = Fnthcdr (TOP, arg);
1131 Lisp_Object arg = POP;
1132 TOP = Felt (TOP, arg);
1138 Lisp_Object arg = POP;
1139 TOP = Fmember (TOP, arg);
1144 TOP = Fgoto_char (TOP, Qnil);
1147 case Bcurrent_buffer:
1150 XSETBUFFER (buffer, current_buffer);
1156 TOP = Fset_buffer (TOP);
1160 PUSH (make_int (BUF_ZV (current_buffer)));
1164 PUSH (make_int (BUF_BEGV (current_buffer)));
1167 case Bskip_chars_forward:
1169 Lisp_Object arg = POP;
1170 TOP = Fskip_chars_forward (TOP, arg, Qnil);
1176 Lisp_Object arg = POP;
1177 TOP = Fassq (TOP, arg);
1183 Lisp_Object arg = POP;
1184 TOP = Fsetcar (TOP, arg);
1190 Lisp_Object arg = POP;
1191 TOP = Fsetcdr (TOP, arg);
1196 TOP = bytecode_nreverse (TOP);
1200 TOP = CONSP (TOP) ? XCAR (TOP) : Qnil;
1204 TOP = CONSP (TOP) ? XCDR (TOP) : Qnil;
1211 /* It makes a worthwhile performance difference (5%) to shunt
1212 lesser-used opcodes off to a subroutine, to keep the switch in
1213 execute_optimized_program small. If you REALLY care about
1214 performance, you want to keep your heavily executed code away from
1215 rarely executed code, to minimize cache misses.
1217 Don't make this function static, since then the compiler might inline it. */
1219 execute_rare_opcode (Lisp_Object *stack_ptr,
1220 CONST Opbyte *program_ptr,
1226 case Bsave_excursion:
1227 record_unwind_protect (save_excursion_restore,
1228 save_excursion_save ());
1231 case Bsave_window_excursion:
1233 int count = specpdl_depth ();
1234 record_unwind_protect (save_window_excursion_unwind,
1235 Fcurrent_window_configuration (Qnil));
1237 unbind_to (count, Qnil);
1241 case Bsave_restriction:
1242 record_unwind_protect (save_restriction_restore,
1243 save_restriction_save ());
1248 Lisp_Object arg = POP;
1249 TOP = internal_catch (TOP, Feval, arg, 0);
1253 case Bskip_chars_backward:
1255 Lisp_Object arg = POP;
1256 TOP = Fskip_chars_backward (TOP, arg, Qnil);
1260 case Bunwind_protect:
1261 record_unwind_protect (Fprogn, POP);
1264 case Bcondition_case:
1266 Lisp_Object arg2 = POP; /* handlers */
1267 Lisp_Object arg1 = POP; /* bodyform */
1268 TOP = condition_case_3 (arg1, TOP, arg2);
1274 Lisp_Object arg2 = POP;
1275 Lisp_Object arg1 = POP;
1276 TOP = Fset_marker (TOP, arg1, arg2);
1282 Lisp_Object arg = POP;
1283 TOP = Frem (TOP, arg);
1287 case Bmatch_beginning:
1288 TOP = Fmatch_beginning (TOP);
1292 TOP = Fmatch_end (TOP);
1296 TOP = Fupcase (TOP, Qnil);
1300 TOP = Fdowncase (TOP, Qnil);
1305 Lisp_Object arg = POP;
1306 TOP = Ffset (TOP, arg);
1312 Lisp_Object arg = POP;
1313 TOP = Fstring_equal (TOP, arg);
1319 Lisp_Object arg = POP;
1320 TOP = Fstring_lessp (TOP, arg);
1326 Lisp_Object arg2 = POP;
1327 Lisp_Object arg1 = POP;
1328 TOP = Fsubstring (TOP, arg1, arg2);
1332 case Bcurrent_column:
1333 PUSH (make_int (current_column (current_buffer)));
1337 TOP = Fchar_after (TOP, Qnil);
1341 TOP = Findent_to (TOP, Qnil, Qnil);
1345 PUSH (Fwiden (Qnil));
1348 case Bfollowing_char:
1349 PUSH (Ffollowing_char (Qnil));
1352 case Bpreceding_char:
1353 PUSH (Fpreceding_char (Qnil));
1357 PUSH (Feolp (Qnil));
1361 PUSH (Feobp (Qnil));
1365 PUSH (Fbolp (Qnil));
1369 PUSH (Fbobp (Qnil));
1372 case Bsave_current_buffer:
1373 record_unwind_protect (save_current_buffer_restore,
1374 Fcurrent_buffer ());
1377 case Binteractive_p:
1378 PUSH (Finteractive_p ());
1382 TOP = Fforward_char (TOP, Qnil);
1386 TOP = Fforward_word (TOP, Qnil);
1390 TOP = Fforward_line (TOP, Qnil);
1394 TOP = Fchar_syntax (TOP, Qnil);
1397 case Bbuffer_substring:
1399 Lisp_Object arg = POP;
1400 TOP = Fbuffer_substring (TOP, arg, Qnil);
1404 case Bdelete_region:
1406 Lisp_Object arg = POP;
1407 TOP = Fdelete_region (TOP, arg, Qnil);
1411 case Bnarrow_to_region:
1413 Lisp_Object arg = POP;
1414 TOP = Fnarrow_to_region (TOP, arg, Qnil);
1419 TOP = Fend_of_line (TOP, Qnil);
1422 case Btemp_output_buffer_setup:
1423 temp_output_buffer_setup (TOP);
1424 TOP = Vstandard_output;
1427 case Btemp_output_buffer_show:
1429 Lisp_Object arg = POP;
1430 temp_output_buffer_show (TOP, Qnil);
1433 /* pop binding of standard-output */
1434 unbind_to (specpdl_depth() - 1, Qnil);
1440 Lisp_Object arg = POP;
1441 TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
1447 Lisp_Object arg = POP;
1448 TOP = Fold_memq (TOP, arg);
1454 Lisp_Object arg = POP;
1455 TOP = Fold_equal (TOP, arg);
1461 Lisp_Object arg = POP;
1462 TOP = Fold_member (TOP, arg);
1468 Lisp_Object arg = POP;
1469 TOP = Fold_assq (TOP, arg);
1482 invalid_byte_code_error (char *error_message, ...)
1486 char *buf = alloca_array (char, strlen (error_message) + 128);
1488 sprintf (buf, "%s", error_message);
1489 va_start (args, error_message);
1490 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (buf), Qnil, -1,
1494 signal_error (Qinvalid_byte_code, list1 (obj));
1497 /* Check for valid opcodes. Change this when adding new opcodes. */
1499 check_opcode (Opcode opcode)
1501 if ((opcode < Bvarref) ||
1503 (opcode > Bassq && opcode < Bconstant))
1504 invalid_byte_code_error
1505 ("invalid opcode %d in instruction stream", opcode);
1508 /* Check that IDX is a valid offset into the `constants' vector */
1510 check_constants_index (int idx, Lisp_Object constants)
1512 if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
1513 invalid_byte_code_error
1514 ("reference %d to constants array out of range 0, %d",
1515 idx, XVECTOR_LENGTH (constants) - 1);
1518 /* Get next character from Lisp instructions string. */
1519 #define READ_INSTRUCTION_CHAR(lvalue) do { \
1520 (lvalue) = charptr_emchar (ptr); \
1521 INC_CHARPTR (ptr); \
1522 *icounts_ptr++ = program_ptr - program; \
1523 if (lvalue > UCHAR_MAX) \
1524 invalid_byte_code_error \
1525 ("Invalid character %c in byte code string"); \
1528 /* Get opcode from Lisp instructions string. */
1529 #define READ_OPCODE do { \
1531 READ_INSTRUCTION_CHAR (c); \
1532 opcode = (Opcode) c; \
1535 /* Get next operand, a uint8, from Lisp instructions string. */
1536 #define READ_OPERAND_1 do { \
1537 READ_INSTRUCTION_CHAR (arg); \
1541 /* Get next operand, a uint16, from Lisp instructions string. */
1542 #define READ_OPERAND_2 do { \
1543 unsigned int arg1, arg2; \
1544 READ_INSTRUCTION_CHAR (arg1); \
1545 READ_INSTRUCTION_CHAR (arg2); \
1546 arg = arg1 + (arg2 << 8); \
1550 /* Write 1 byte to PTR, incrementing PTR */
1551 #define WRITE_INT8(value, ptr) do { \
1552 *((ptr)++) = (value); \
1555 /* Write 2 bytes to PTR, incrementing PTR */
1556 #define WRITE_INT16(value, ptr) do { \
1557 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \
1558 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \
1561 /* We've changed our minds about the opcode we've already written. */
1562 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
1564 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
1565 #define WRITE_NARGS(base_opcode) do { \
1568 REWRITE_OPCODE (base_opcode + arg); \
1570 else if (arg <= UCHAR_MAX) \
1572 REWRITE_OPCODE (base_opcode + 6); \
1573 WRITE_INT8 (arg, program_ptr); \
1577 REWRITE_OPCODE (base_opcode + 7); \
1578 WRITE_INT16 (arg, program_ptr); \
1582 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
1583 #define WRITE_CONSTANT do { \
1584 check_constants_index(arg, constants); \
1585 if (arg <= UCHAR_MAX - Bconstant) \
1587 REWRITE_OPCODE (Bconstant + arg); \
1591 REWRITE_OPCODE (Bconstant2); \
1592 WRITE_INT16 (arg, program_ptr); \
1596 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
1598 /* Compile byte code instructions into free space provided by caller, with
1599 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
1600 Returns length of compiled code. */
1602 optimize_byte_code (/* in */
1603 Lisp_Object instructions,
1604 Lisp_Object constants,
1606 Opbyte * CONST program,
1607 int * CONST program_length,
1608 int * CONST varbind_count)
1610 size_t instructions_length = XSTRING_LENGTH (instructions);
1611 size_t comfy_size = 2 * instructions_length;
1613 int * CONST icounts = alloca_array (int, comfy_size);
1614 int * icounts_ptr = icounts;
1616 /* We maintain a table of jumps in the source code. */
1622 struct jump * CONST jumps = alloca_array (struct jump, comfy_size);
1623 struct jump *jumps_ptr = jumps;
1625 Opbyte *program_ptr = program;
1627 CONST Bufbyte *ptr = XSTRING_DATA (instructions);
1628 CONST Bufbyte * CONST end = ptr + instructions_length;
1644 case Bvarref+7: READ_OPERAND_2; goto do_varref;
1645 case Bvarref+6: READ_OPERAND_1; goto do_varref;
1646 case Bvarref: case Bvarref+1: case Bvarref+2:
1647 case Bvarref+3: case Bvarref+4: case Bvarref+5:
1648 arg = opcode - Bvarref;
1650 check_constants_index (arg, constants);
1651 val = XVECTOR_DATA (constants) [arg];
1653 invalid_byte_code_error ("variable reference to non-symbol %S", val);
1654 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1655 invalid_byte_code_error ("variable reference to constant symbol %s",
1656 string_data (XSYMBOL (val)->name));
1657 WRITE_NARGS (Bvarref);
1660 case Bvarset+7: READ_OPERAND_2; goto do_varset;
1661 case Bvarset+6: READ_OPERAND_1; goto do_varset;
1662 case Bvarset: case Bvarset+1: case Bvarset+2:
1663 case Bvarset+3: case Bvarset+4: case Bvarset+5:
1664 arg = opcode - Bvarset;
1666 check_constants_index (arg, constants);
1667 val = XVECTOR_DATA (constants) [arg];
1669 invalid_byte_code_error ("attempt to set non-symbol %S", val);
1670 if (EQ (val, Qnil) || EQ (val, Qt))
1671 invalid_byte_code_error ("attempt to set constant symbol %s",
1672 string_data (XSYMBOL (val)->name));
1673 /* Ignore assignments to keywords by converting to Bdiscard.
1674 For backward compatibility only - we'd like to make this an error. */
1675 if (SYMBOL_IS_KEYWORD (val))
1676 REWRITE_OPCODE (Bdiscard);
1678 WRITE_NARGS (Bvarset);
1681 case Bvarbind+7: READ_OPERAND_2; goto do_varbind;
1682 case Bvarbind+6: READ_OPERAND_1; goto do_varbind;
1683 case Bvarbind: case Bvarbind+1: case Bvarbind+2:
1684 case Bvarbind+3: case Bvarbind+4: case Bvarbind+5:
1685 arg = opcode - Bvarbind;
1688 check_constants_index (arg, constants);
1689 val = XVECTOR_DATA (constants) [arg];
1691 invalid_byte_code_error ("attempt to let-bind non-symbol %S", val);
1692 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1693 invalid_byte_code_error ("attempt to let-bind constant symbol %s",
1694 string_data (XSYMBOL (val)->name));
1695 WRITE_NARGS (Bvarbind);
1698 case Bcall+7: READ_OPERAND_2; goto do_call;
1699 case Bcall+6: READ_OPERAND_1; goto do_call;
1700 case Bcall: case Bcall+1: case Bcall+2:
1701 case Bcall+3: case Bcall+4: case Bcall+5:
1702 arg = opcode - Bcall;
1704 WRITE_NARGS (Bcall);
1707 case Bunbind+7: READ_OPERAND_2; goto do_unbind;
1708 case Bunbind+6: READ_OPERAND_1; goto do_unbind;
1709 case Bunbind: case Bunbind+1: case Bunbind+2:
1710 case Bunbind+3: case Bunbind+4: case Bunbind+5:
1711 arg = opcode - Bunbind;
1713 WRITE_NARGS (Bunbind);
1719 case Bgotoifnilelsepop:
1720 case Bgotoifnonnilelsepop:
1722 /* Make program_ptr-relative */
1723 arg += icounts - (icounts_ptr - argsize);
1728 case BRgotoifnonnil:
1729 case BRgotoifnilelsepop:
1730 case BRgotoifnonnilelsepop:
1732 /* Make program_ptr-relative */
1735 /* Record program-relative goto addresses in `jumps' table */
1736 jumps_ptr->from = icounts_ptr - icounts - argsize;
1737 jumps_ptr->to = jumps_ptr->from + arg;
1739 if (arg >= -1 && arg <= argsize)
1740 invalid_byte_code_error
1741 ("goto instruction is its own target");
1742 if (arg <= SCHAR_MIN ||
1746 REWRITE_OPCODE (opcode + Bgoto - BRgoto);
1747 WRITE_INT16 (arg, program_ptr);
1752 REWRITE_OPCODE (opcode + BRgoto - Bgoto);
1753 WRITE_INT8 (arg, program_ptr);
1766 WRITE_INT8 (arg, program_ptr);
1770 if (opcode < Bconstant)
1771 check_opcode (opcode);
1774 arg = opcode - Bconstant;
1781 /* Fix up jumps table to refer to NEW offsets. */
1784 for (j = jumps; j < jumps_ptr; j++)
1786 #ifdef ERROR_CHECK_BYTE_CODE
1787 assert (j->from < icounts_ptr - icounts);
1788 assert (j->to < icounts_ptr - icounts);
1790 j->from = icounts[j->from];
1791 j->to = icounts[j->to];
1792 #ifdef ERROR_CHECK_BYTE_CODE
1793 assert (j->from < program_ptr - program);
1794 assert (j->to < program_ptr - program);
1795 check_opcode ((Opcode) (program[j->from-1]));
1797 check_opcode ((Opcode) (program[j->to]));
1801 /* Fixup jumps in byte-code until no more fixups needed */
1803 int more_fixups_needed = 1;
1805 while (more_fixups_needed)
1808 more_fixups_needed = 0;
1809 for (j = jumps; j < jumps_ptr; j++)
1813 int jump = to - from;
1814 Opbyte *p = program + from;
1815 Opcode opcode = (Opcode) p[-1];
1816 if (!more_fixups_needed)
1817 check_opcode ((Opcode) p[jump]);
1818 assert (to >= 0 && program + to < program_ptr);
1824 case Bgotoifnilelsepop:
1825 case Bgotoifnonnilelsepop:
1826 WRITE_INT16 (jump, p);
1831 case BRgotoifnonnil:
1832 case BRgotoifnilelsepop:
1833 case BRgotoifnonnilelsepop:
1834 if (jump > SCHAR_MIN &&
1837 WRITE_INT8 (jump, p);
1842 for (jj = jumps; jj < jumps_ptr; jj++)
1844 assert (jj->from < program_ptr - program);
1845 assert (jj->to < program_ptr - program);
1846 if (jj->from > from) jj->from++;
1847 if (jj->to > from) jj->to++;
1849 p[-1] += Bgoto - BRgoto;
1850 more_fixups_needed = 1;
1851 memmove (p+1, p, program_ptr++ - p);
1852 WRITE_INT16 (jump, p);
1864 /* *program_ptr++ = 0; */
1865 *program_length = program_ptr - program;
1868 /* Optimize the byte code and store the optimized program, only
1869 understood by bytecode.c, in an opaque object in the
1870 instructions slot of the Compiled_Function object. */
1872 optimize_compiled_function (Lisp_Object compiled_function)
1874 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
1879 /* If we have not actually read the bytecode string
1880 and constants vector yet, fetch them from the file. */
1881 if (CONSP (f->instructions))
1882 Ffetch_bytecode (compiled_function);
1884 if (STRINGP (f->instructions))
1886 /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1887 which would be slightly more `proper' */
1888 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
1889 optimize_byte_code (f->instructions, f->constants,
1890 program, &program_length, &varbind_count);
1891 f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
1893 make_opaque (program_length * sizeof (Opbyte),
1894 (CONST void *) program);
1897 assert (OPAQUEP (f->instructions));
1900 /************************************************************************/
1901 /* The compiled-function object type */
1902 /************************************************************************/
1904 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
1907 /* This function can GC */
1908 Lisp_Compiled_Function *f =
1909 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
1910 int docp = f->flags.documentationp;
1911 int intp = f->flags.interactivep;
1912 struct gcpro gcpro1, gcpro2;
1914 GCPRO2 (obj, printcharfun);
1916 write_c_string (print_readably ? "#[" : "#<compiled-function ", printcharfun);
1917 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1918 if (!print_readably)
1920 Lisp_Object ann = compiled_function_annotation (f);
1923 write_c_string ("(from ", printcharfun);
1924 print_internal (ann, printcharfun, 1);
1925 write_c_string (") ", printcharfun);
1928 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1929 /* COMPILED_ARGLIST = 0 */
1930 print_internal (compiled_function_arglist (f), printcharfun, escapeflag);
1932 /* COMPILED_INSTRUCTIONS = 1 */
1933 write_c_string (" ", printcharfun);
1935 struct gcpro ngcpro1;
1936 Lisp_Object instructions = compiled_function_instructions (f);
1937 NGCPRO1 (instructions);
1938 if (STRINGP (instructions) && !print_readably)
1940 /* We don't usually want to see that junk in the bytecode. */
1941 sprintf (buf, "\"...(%ld)\"",
1942 (long) XSTRING_CHAR_LENGTH (instructions));
1943 write_c_string (buf, printcharfun);
1946 print_internal (instructions, printcharfun, escapeflag);
1950 /* COMPILED_CONSTANTS = 2 */
1951 write_c_string (" ", printcharfun);
1952 print_internal (compiled_function_constants (f), printcharfun, escapeflag);
1954 /* COMPILED_STACK_DEPTH = 3 */
1955 sprintf (buf, " %d", compiled_function_stack_depth (f));
1956 write_c_string (buf, printcharfun);
1958 /* COMPILED_DOC_STRING = 4 */
1961 write_c_string (" ", printcharfun);
1962 print_internal (compiled_function_documentation (f), printcharfun,
1966 /* COMPILED_INTERACTIVE = 5 */
1969 write_c_string (" ", printcharfun);
1970 print_internal (compiled_function_interactive (f), printcharfun,
1975 write_c_string (print_readably ? "]" : ">", printcharfun);
1980 mark_compiled_function (Lisp_Object obj)
1982 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1984 mark_object (f->instructions);
1985 mark_object (f->arglist);
1986 mark_object (f->doc_and_interactive);
1987 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1988 mark_object (f->annotated);
1990 /* tail-recurse on constants */
1991 return f->constants;
1995 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1997 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1);
1998 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
2000 (f1->flags.documentationp == f2->flags.documentationp &&
2001 f1->flags.interactivep == f2->flags.interactivep &&
2002 f1->flags.domainp == f2->flags.domainp && /* I18N3 */
2003 internal_equal (compiled_function_instructions (f1),
2004 compiled_function_instructions (f2), depth + 1) &&
2005 internal_equal (f1->constants, f2->constants, depth + 1) &&
2006 internal_equal (f1->arglist, f2->arglist, depth + 1) &&
2007 internal_equal (f1->doc_and_interactive,
2008 f2->doc_and_interactive, depth + 1));
2011 static unsigned long
2012 compiled_function_hash (Lisp_Object obj, int depth)
2014 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
2015 return HASH3 ((f->flags.documentationp << 2) +
2016 (f->flags.interactivep << 1) +
2018 internal_hash (f->instructions, depth + 1),
2019 internal_hash (f->constants, depth + 1));
2022 static const struct lrecord_description compiled_function_description[] = {
2023 { XD_LISP_OBJECT, offsetof(struct Lisp_Compiled_Function, instructions), 4 },
2024 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2025 { XD_LISP_OBJECT, offsetof(struct Lisp_Compiled_Function, annotated), 1 },
2030 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
2031 mark_compiled_function,
2032 print_compiled_function, 0,
2033 compiled_function_equal,
2034 compiled_function_hash,
2035 compiled_function_description,
2036 Lisp_Compiled_Function);
2038 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
2039 Return t if OBJECT is a byte-compiled function object.
2043 return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
2046 /************************************************************************/
2047 /* compiled-function object accessor functions */
2048 /************************************************************************/
2051 compiled_function_arglist (Lisp_Compiled_Function *f)
2057 compiled_function_instructions (Lisp_Compiled_Function *f)
2059 if (! OPAQUEP (f->instructions))
2060 return f->instructions;
2063 /* Invert action performed by optimize_byte_code() */
2064 Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2066 Bufbyte * CONST buffer =
2067 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2068 Bufbyte *bp = buffer;
2070 CONST Opbyte * CONST program = (CONST Opbyte *) OPAQUE_DATA (opaque);
2071 CONST Opbyte *program_ptr = program;
2072 CONST Opbyte * CONST program_end = program_ptr + OPAQUE_SIZE (opaque);
2074 while (program_ptr < program_end)
2076 Opcode opcode = (Opcode) READ_UINT_1;
2077 bp += set_charptr_emchar (bp, opcode);
2086 bp += set_charptr_emchar (bp, READ_UINT_1);
2087 bp += set_charptr_emchar (bp, READ_UINT_1);
2098 bp += set_charptr_emchar (bp, READ_UINT_1);
2104 case Bgotoifnilelsepop:
2105 case Bgotoifnonnilelsepop:
2107 int jump = READ_INT_2;
2109 Opbyte *buf2p = buf2;
2110 /* Convert back to program-relative address */
2111 WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
2112 bp += set_charptr_emchar (bp, buf2[0]);
2113 bp += set_charptr_emchar (bp, buf2[1]);
2119 case BRgotoifnonnil:
2120 case BRgotoifnilelsepop:
2121 case BRgotoifnonnilelsepop:
2122 bp += set_charptr_emchar (bp, READ_INT_1 + 127);
2129 return make_string (buffer, bp - buffer);
2134 compiled_function_constants (Lisp_Compiled_Function *f)
2136 return f->constants;
2140 compiled_function_stack_depth (Lisp_Compiled_Function *f)
2142 return f->stack_depth;
2145 /* The compiled_function->doc_and_interactive slot uses the minimal
2146 number of conses, based on compiled_function->flags; it may take
2147 any of the following forms:
2154 (interactive . domain)
2155 (doc . (interactive . domain))
2158 /* Caller must check flags.interactivep first */
2160 compiled_function_interactive (Lisp_Compiled_Function *f)
2162 assert (f->flags.interactivep);
2163 if (f->flags.documentationp && f->flags.domainp)
2164 return XCAR (XCDR (f->doc_and_interactive));
2165 else if (f->flags.documentationp)
2166 return XCDR (f->doc_and_interactive);
2167 else if (f->flags.domainp)
2168 return XCAR (f->doc_and_interactive);
2170 return f->doc_and_interactive;
2173 /* Caller need not check flags.documentationp first */
2175 compiled_function_documentation (Lisp_Compiled_Function *f)
2177 if (! f->flags.documentationp)
2179 else if (f->flags.interactivep && f->flags.domainp)
2180 return XCAR (f->doc_and_interactive);
2181 else if (f->flags.interactivep)
2182 return XCAR (f->doc_and_interactive);
2183 else if (f->flags.domainp)
2184 return XCAR (f->doc_and_interactive);
2186 return f->doc_and_interactive;
2189 /* Caller need not check flags.domainp first */
2191 compiled_function_domain (Lisp_Compiled_Function *f)
2193 if (! f->flags.domainp)
2195 else if (f->flags.documentationp && f->flags.interactivep)
2196 return XCDR (XCDR (f->doc_and_interactive));
2197 else if (f->flags.documentationp)
2198 return XCDR (f->doc_and_interactive);
2199 else if (f->flags.interactivep)
2200 return XCDR (f->doc_and_interactive);
2202 return f->doc_and_interactive;
2205 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2208 compiled_function_annotation (Lisp_Compiled_Function *f)
2210 return f->annotated;
2215 /* used only by Snarf-documentation; there must be doc already. */
2217 set_compiled_function_documentation (Lisp_Compiled_Function *f,
2218 Lisp_Object new_doc)
2220 assert (f->flags.documentationp);
2221 assert (INTP (new_doc) || STRINGP (new_doc));
2223 if (f->flags.interactivep && f->flags.domainp)
2224 XCAR (f->doc_and_interactive) = new_doc;
2225 else if (f->flags.interactivep)
2226 XCAR (f->doc_and_interactive) = new_doc;
2227 else if (f->flags.domainp)
2228 XCAR (f->doc_and_interactive) = new_doc;
2230 f->doc_and_interactive = new_doc;
2234 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2235 Return the argument list of the compiled-function object FUNCTION.
2239 CHECK_COMPILED_FUNCTION (function);
2240 return compiled_function_arglist (XCOMPILED_FUNCTION (function));
2243 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
2244 Return the byte-opcode string of the compiled-function object FUNCTION.
2248 CHECK_COMPILED_FUNCTION (function);
2249 return compiled_function_instructions (XCOMPILED_FUNCTION (function));
2252 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
2253 Return the constants vector of the compiled-function object FUNCTION.
2257 CHECK_COMPILED_FUNCTION (function);
2258 return compiled_function_constants (XCOMPILED_FUNCTION (function));
2261 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2262 Return the max stack depth of the compiled-function object FUNCTION.
2266 CHECK_COMPILED_FUNCTION (function);
2267 return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
2270 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
2271 Return the doc string of the compiled-function object FUNCTION, if available.
2272 Functions that had their doc strings snarfed into the DOC file will have
2273 an integer returned instead of a string.
2277 CHECK_COMPILED_FUNCTION (function);
2278 return compiled_function_documentation (XCOMPILED_FUNCTION (function));
2281 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2282 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2283 If non-nil, the return value will be a list whose first element is
2284 `interactive' and whose second element is the interactive spec.
2288 CHECK_COMPILED_FUNCTION (function);
2289 return XCOMPILED_FUNCTION (function)->flags.interactivep
2290 ? list2 (Qinteractive,
2291 compiled_function_interactive (XCOMPILED_FUNCTION (function)))
2295 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2297 /* Remove the `xx' if you wish to restore this feature */
2298 xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2299 Return the annotation of the compiled-function object FUNCTION, or nil.
2300 The annotation is a piece of information indicating where this
2301 compiled-function object came from. Generally this will be
2302 a symbol naming a function; or a string naming a file, if the
2303 compiled-function object was not defined in a function; or nil,
2304 if the compiled-function object was not created as a result of
2309 CHECK_COMPILED_FUNCTION (function);
2310 return compiled_function_annotation (XCOMPILED_FUNCTION (function));
2313 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2315 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
2316 Return the domain of the compiled-function object FUNCTION, or nil.
2317 This is only meaningful if I18N3 was enabled when emacs was compiled.
2321 CHECK_COMPILED_FUNCTION (function);
2322 return XCOMPILED_FUNCTION (function)->flags.domainp
2323 ? compiled_function_domain (XCOMPILED_FUNCTION (function))
2329 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
2330 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2334 Lisp_Compiled_Function *f;
2335 CHECK_COMPILED_FUNCTION (function);
2336 f = XCOMPILED_FUNCTION (function);
2338 if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
2341 if (CONSP (f->instructions))
2343 Lisp_Object tem = read_doc_string (f->instructions);
2345 signal_simple_error ("Invalid lazy-loaded byte code", tem);
2346 /* v18 or v19 bytecode file. Need to Ebolify. */
2347 if (f->flags.ebolified && VECTORP (XCDR (tem)))
2348 ebolify_bytecode_constants (XCDR (tem));
2349 f->instructions = XCAR (tem);
2350 f->constants = XCDR (tem);
2354 return Qnil; /* not reached */
2357 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
2358 Convert compiled function FUNCTION into an optimized internal form.
2362 Lisp_Compiled_Function *f;
2363 CHECK_COMPILED_FUNCTION (function);
2364 f = XCOMPILED_FUNCTION (function);
2366 if (OPAQUEP (f->instructions)) /* Already optimized? */
2369 optimize_compiled_function (function);
2373 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
2374 Function used internally in byte-compiled code.
2375 First argument INSTRUCTIONS is a string of byte code.
2376 Second argument CONSTANTS is a vector of constants.
2377 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2378 If STACK-DEPTH is incorrect, Emacs may crash.
2380 (instructions, constants, stack_depth))
2382 /* This function can GC */
2387 CHECK_STRING (instructions);
2388 CHECK_VECTOR (constants);
2389 CHECK_NATNUM (stack_depth);
2391 /* Optimize the `instructions' string, just like when executing a
2392 regular compiled function, but don't save it for later since this is
2393 likely to only be executed once. */
2394 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
2395 optimize_byte_code (instructions, constants, program,
2396 &program_length, &varbind_count);
2397 SPECPDL_RESERVE (varbind_count);
2398 return execute_optimized_program (program,
2400 XVECTOR_DATA (constants));
2405 syms_of_bytecode (void)
2407 deferror (&Qinvalid_byte_code, "invalid-byte-code",
2408 "Invalid byte code", Qerror);
2409 defsymbol (&Qbyte_code, "byte-code");
2410 defsymbol (&Qcompiled_functionp, "compiled-function-p");
2412 DEFSUBR (Fbyte_code);
2413 DEFSUBR (Ffetch_bytecode);
2414 DEFSUBR (Foptimize_compiled_function);
2416 DEFSUBR (Fcompiled_function_p);
2417 DEFSUBR (Fcompiled_function_instructions);
2418 DEFSUBR (Fcompiled_function_constants);
2419 DEFSUBR (Fcompiled_function_stack_depth);
2420 DEFSUBR (Fcompiled_function_arglist);
2421 DEFSUBR (Fcompiled_function_interactive);
2422 DEFSUBR (Fcompiled_function_doc_string);
2423 DEFSUBR (Fcompiled_function_domain);
2424 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2425 DEFSUBR (Fcompiled_function_annotation);
2428 #ifdef BYTE_CODE_METER
2429 defsymbol (&Qbyte_code_meter, "byte-code-meter");
2434 vars_of_bytecode (void)
2436 #ifdef BYTE_CODE_METER
2438 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
2439 A vector of vectors which holds a histogram of byte code usage.
2440 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2441 opcode CODE has been executed.
2442 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2443 indicates how many times the byte opcodes CODE1 and CODE2 have been
2444 executed in succession.
2446 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /*
2447 If non-nil, keep profiling information on byte code usage.
2448 The variable `byte-code-meter' indicates how often each byte opcode is used.
2449 If a symbol has a property named `byte-code-meter' whose value is an
2450 integer, it is incremented each time that symbol's function is called.
2453 byte_metering_on = 0;
2454 Vbyte_code_meter = make_vector (256, Qzero);
2458 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
2460 #endif /* BYTE_CODE_METER */