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"
59 EXFUN (Ffetch_bytecode, 1);
61 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
63 enum Opcode /* Byte codes */
90 Bsymbol_function = 0113,
113 Beq = 0141, /* was Bmark,
114 but no longer generated as of v18 */
120 Bfollowing_char = 0147,
121 Bpreceding_char = 0150,
122 Bcurrent_column = 0151,
124 Bequal = 0153, /* was Bscan_buffer,
125 but no longer generated as of v18 */
130 Bcurrent_buffer = 0160,
132 Bsave_current_buffer = 0162, /* was Bread_char,
133 but no longer generated as of v19 */
134 Bmemq = 0163, /* was Bset_mark,
135 but no longer generated as of v18 */
136 Binteractive_p = 0164, /* Needed since interactive-p takes
138 Bforward_char = 0165,
139 Bforward_word = 0166,
140 Bskip_chars_forward = 0167,
141 Bskip_chars_backward = 0170,
142 Bforward_line = 0171,
144 Bbuffer_substring = 0173,
145 Bdelete_region = 0174,
146 Bnarrow_to_region = 0175,
153 Bgotoifnonnil = 0204,
154 Bgotoifnilelsepop = 0205,
155 Bgotoifnonnilelsepop = 0206,
160 Bsave_excursion = 0212,
161 Bsave_window_excursion= 0213,
162 Bsave_restriction = 0214,
165 Bunwind_protect = 0216,
166 Bcondition_case = 0217,
167 Btemp_output_buffer_setup = 0220,
168 Btemp_output_buffer_show = 0221,
173 Bmatch_beginning = 0224,
178 Bstring_equal = 0230,
179 Bstring_lessp = 0231,
198 BRgotoifnonnil = 0254,
199 BRgotoifnilelsepop = 0255,
200 BRgotoifnonnilelsepop = 0256,
205 Bmember = 0266, /* new in v20 */
206 Bassq = 0267, /* new in v20 */
210 typedef enum Opcode Opcode;
211 typedef unsigned char Opbyte;
214 static void check_opcode (Opcode opcode);
215 static void invalid_byte_code_error (char *error_message, ...);
217 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
218 const Opbyte *program_ptr,
221 static Lisp_Object execute_optimized_program (const Opbyte *program,
223 Lisp_Object *constants_data);
225 extern Lisp_Object Qand_rest, Qand_optional;
227 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
228 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
229 /* #define BYTE_CODE_METER */
232 #ifdef BYTE_CODE_METER
234 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
235 int byte_metering_on;
238 meter_code (Opcode prev_opcode, Opcode this_opcode)
240 if (byte_metering_on)
242 Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]);
243 p[0] = INT_PLUS1 (p[0]);
245 p[prev_opcode] = INT_PLUS1 (p[prev_opcode]);
249 #endif /* BYTE_CODE_METER */
253 bytecode_negate (Lisp_Object obj)
257 if (INTP (obj)) return make_int (- XINT (obj));
258 #ifdef LISP_FLOAT_TYPE
259 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
261 if (CHARP (obj)) return make_int (- ((int) XCHAR (obj)));
262 if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));
264 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
269 bytecode_nreverse (Lisp_Object list)
271 REGISTER Lisp_Object prev = Qnil;
272 REGISTER Lisp_Object tail = list;
276 REGISTER Lisp_Object next;
287 /* We have our own two-argument versions of various arithmetic ops.
288 Only two-argument arithmetic operations have their own byte codes. */
290 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2)
294 #ifdef LISP_FLOAT_TYPE
296 EMACS_INT ival1, ival2;
298 if (INTP (obj1)) ival1 = XINT (obj1);
299 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
300 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
301 else goto arithcompare_float;
303 if (INTP (obj2)) ival2 = XINT (obj2);
304 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
305 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
306 else goto arithcompare_float;
308 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
316 if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1);
317 else if (INTP (obj1)) dval1 = (double) XINT (obj1);
318 else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1);
319 else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1);
322 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
326 if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2);
327 else if (INTP (obj2)) dval2 = (double) XINT (obj2);
328 else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2);
329 else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2);
332 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
336 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
338 #else /* !LISP_FLOAT_TYPE */
340 EMACS_INT ival1, ival2;
342 if (INTP (obj1)) ival1 = XINT (obj1);
343 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
344 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
347 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
351 if (INTP (obj2)) ival2 = XINT (obj2);
352 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
353 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
356 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
360 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
362 #endif /* !LISP_FLOAT_TYPE */
366 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
368 #ifdef LISP_FLOAT_TYPE
369 EMACS_INT ival1, ival2;
376 if (INTP (obj1)) ival1 = XINT (obj1);
377 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
378 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
379 else if (FLOATP (obj1)) ival1 = 0, float_p = 1;
382 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
386 if (INTP (obj2)) ival2 = XINT (obj2);
387 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
388 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
389 else if (FLOATP (obj2)) ival2 = 0, float_p = 1;
392 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
400 case Bplus: ival1 += ival2; break;
401 case Bdiff: ival1 -= ival2; break;
402 case Bmult: ival1 *= ival2; break;
404 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
407 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
408 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
410 return make_int (ival1);
414 double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1;
415 double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2;
418 case Bplus: dval1 += dval2; break;
419 case Bdiff: dval1 -= dval2; break;
420 case Bmult: dval1 *= dval2; break;
422 if (dval2 == 0) Fsignal (Qarith_error, Qnil);
425 case Bmax: if (dval1 < dval2) dval1 = dval2; break;
426 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
428 return make_float (dval1);
430 #else /* !LISP_FLOAT_TYPE */
431 EMACS_INT ival1, ival2;
435 if (INTP (obj1)) ival1 = XINT (obj1);
436 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
437 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
440 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
444 if (INTP (obj2)) ival2 = XINT (obj2);
445 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
446 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
449 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
455 case Bplus: ival1 += ival2; break;
456 case Bdiff: ival1 -= ival2; break;
457 case Bmult: ival1 *= ival2; break;
459 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
462 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
463 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
465 return make_int (ival1);
466 #endif /* !LISP_FLOAT_TYPE */
469 /* Apply compiled-function object FUN to the NARGS evaluated arguments
470 in ARGS, and return the result of evaluation. */
472 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[])
474 /* This function can GC */
475 int speccount = specpdl_depth();
477 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
480 if (!OPAQUEP (f->instructions))
481 /* Lazily munge the instructions into a more efficient form */
482 optimize_compiled_function (fun);
484 /* optimize_compiled_function() guaranteed that f->specpdl_depth is
485 the required space on the specbinding stack for binding the args
486 and local variables of fun. So just reserve it once. */
487 SPECPDL_RESERVE (f->specpdl_depth);
490 /* Fmake_byte_code() guaranteed that f->arglist is a valid list
491 containing only non-constant symbols. */
492 LIST_LOOP_3 (symbol, f->arglist, tail)
494 if (EQ (symbol, Qand_rest))
497 symbol = XCAR (tail);
498 SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i]));
501 else if (EQ (symbol, Qand_optional))
503 else if (i == nargs && !optional)
504 goto wrong_number_of_arguments;
506 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");
641 check_opcode (opcode);
644 #ifdef BYTE_CODE_METER
645 prev_opcode = this_opcode;
646 this_opcode = opcode;
647 meter_code (prev_opcode, this_opcode);
655 if (opcode >= Bconstant)
656 PUSH (constants_data[opcode - Bconstant]);
658 stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode);
666 case Bvarref+5: n = opcode - Bvarref; goto do_varref;
667 case Bvarref+7: n = READ_UINT_2; goto do_varref;
668 case Bvarref+6: n = READ_UINT_1; /* most common */
671 Lisp_Object symbol = constants_data[n];
672 Lisp_Object value = XSYMBOL (symbol)->value;
673 if (SYMBOL_VALUE_MAGIC_P (value))
674 value = Fsymbol_value (symbol);
684 case Bvarset+5: n = opcode - Bvarset; goto do_varset;
685 case Bvarset+7: n = READ_UINT_2; goto do_varset;
686 case Bvarset+6: n = READ_UINT_1; /* most common */
689 Lisp_Object symbol = constants_data[n];
690 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
691 Lisp_Object old_value = symbol_ptr->value;
692 Lisp_Object new_value = POP;
693 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
694 symbol_ptr->value = new_value;
696 Fset (symbol, new_value);
705 case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind;
706 case Bvarbind+7: n = READ_UINT_2; goto do_varbind;
707 case Bvarbind+6: n = READ_UINT_1; /* most common */
710 Lisp_Object symbol = constants_data[n];
711 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
712 Lisp_Object old_value = symbol_ptr->value;
713 Lisp_Object new_value = POP;
714 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
716 specpdl_ptr->symbol = symbol;
717 specpdl_ptr->old_value = old_value;
718 specpdl_ptr->func = 0;
720 specpdl_depth_counter++;
722 symbol_ptr->value = new_value;
725 specbind_magic (symbol, new_value);
737 n = (opcode < Bcall+6 ? opcode - Bcall :
738 opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2);
740 #ifdef BYTE_CODE_METER
741 if (byte_metering_on && SYMBOLP (TOP))
743 Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
745 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
748 TOP = Ffuncall (n + 1, &TOP);
759 UNBIND_TO (specpdl_depth() -
760 (opcode < Bunbind+6 ? opcode-Bunbind :
761 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
783 case Bgotoifnilelsepop:
793 case Bgotoifnonnilelsepop:
822 case BRgotoifnilelsepop:
832 case BRgotoifnonnilelsepop:
844 #ifdef ERROR_CHECK_BYTE_CODE
845 /* Binds and unbinds are supposed to be compiled balanced. */
846 if (specpdl_depth() != speccount)
847 invalid_byte_code_error ("unbalanced specbinding stack");
857 Lisp_Object arg = TOP;
863 PUSH (constants_data[READ_UINT_2]);
867 TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
871 TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
876 /* To unbind back to the beginning of this frame. Not used yet,
877 but will be needed for tail-recursion elimination. */
878 unbind_to (speccount, Qnil);
883 Lisp_Object arg = POP;
884 TOP = Fcar (Fnthcdr (TOP, arg));
889 TOP = SYMBOLP (TOP) ? Qt : Qnil;
893 TOP = CONSP (TOP) ? Qt : Qnil;
897 TOP = STRINGP (TOP) ? Qt : Qnil;
901 TOP = LISTP (TOP) ? Qt : Qnil;
905 TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
909 TOP = INTP (TOP) ? Qt : Qnil;
914 Lisp_Object arg = POP;
915 TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
920 TOP = NILP (TOP) ? Qt : Qnil;
925 Lisp_Object arg = POP;
926 TOP = Fcons (TOP, arg);
931 TOP = Fcons (TOP, Qnil);
943 n = opcode - (Blist1 - 1);
946 Lisp_Object list = Qnil;
948 list = Fcons (TOP, list);
962 n = opcode - (Bconcat2 - 2);
970 TOP = Fconcat (n, &TOP);
980 Lisp_Object arg2 = POP;
981 Lisp_Object arg1 = POP;
982 TOP = Faset (TOP, arg1, arg2);
987 TOP = Fsymbol_value (TOP);
990 case Bsymbol_function:
991 TOP = Fsymbol_function (TOP);
996 Lisp_Object arg = POP;
997 TOP = Fget (TOP, arg, Qnil);
1002 TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
1006 TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
1012 Lisp_Object arg = POP;
1013 TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
1019 Lisp_Object arg = POP;
1020 TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
1026 Lisp_Object arg = POP;
1027 TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
1033 Lisp_Object arg = POP;
1034 TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
1040 Lisp_Object arg = POP;
1041 TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
1047 TOP = bytecode_negate (TOP);
1052 TOP = bytecode_nconc2 (&TOP);
1057 Lisp_Object arg2 = POP;
1058 Lisp_Object arg1 = TOP;
1059 TOP = INTP (arg1) && INTP (arg2) ?
1060 INT_PLUS (arg1, arg2) :
1061 bytecode_arithop (arg1, arg2, opcode);
1067 Lisp_Object arg2 = POP;
1068 Lisp_Object arg1 = TOP;
1069 TOP = INTP (arg1) && INTP (arg2) ?
1070 INT_MINUS (arg1, arg2) :
1071 bytecode_arithop (arg1, arg2, opcode);
1080 Lisp_Object arg = POP;
1081 TOP = bytecode_arithop (TOP, arg, opcode);
1086 PUSH (make_int (BUF_PT (current_buffer)));
1090 TOP = Finsert (1, &TOP);
1096 TOP = Finsert (n, &TOP);
1101 Lisp_Object arg = POP;
1102 TOP = Faref (TOP, arg);
1108 Lisp_Object arg = POP;
1109 TOP = Fmemq (TOP, arg);
1115 Lisp_Object arg = POP;
1116 TOP = Fset (TOP, arg);
1122 Lisp_Object arg = POP;
1123 TOP = Fequal (TOP, arg);
1129 Lisp_Object arg = POP;
1130 TOP = Fnthcdr (TOP, arg);
1136 Lisp_Object arg = POP;
1137 TOP = Felt (TOP, arg);
1143 Lisp_Object arg = POP;
1144 TOP = Fmember (TOP, arg);
1149 TOP = Fgoto_char (TOP, Qnil);
1152 case Bcurrent_buffer:
1155 XSETBUFFER (buffer, current_buffer);
1161 TOP = Fset_buffer (TOP);
1165 PUSH (make_int (BUF_ZV (current_buffer)));
1169 PUSH (make_int (BUF_BEGV (current_buffer)));
1172 case Bskip_chars_forward:
1174 Lisp_Object arg = POP;
1175 TOP = Fskip_chars_forward (TOP, arg, Qnil);
1181 Lisp_Object arg = POP;
1182 TOP = Fassq (TOP, arg);
1188 Lisp_Object arg = POP;
1189 TOP = Fsetcar (TOP, arg);
1195 Lisp_Object arg = POP;
1196 TOP = Fsetcdr (TOP, arg);
1201 TOP = bytecode_nreverse (TOP);
1205 TOP = CONSP (TOP) ? XCAR (TOP) : Qnil;
1209 TOP = CONSP (TOP) ? XCDR (TOP) : Qnil;
1216 /* It makes a worthwhile performance difference (5%) to shunt
1217 lesser-used opcodes off to a subroutine, to keep the switch in
1218 execute_optimized_program small. If you REALLY care about
1219 performance, you want to keep your heavily executed code away from
1220 rarely executed code, to minimize cache misses.
1222 Don't make this function static, since then the compiler might inline it. */
1224 execute_rare_opcode (Lisp_Object *stack_ptr,
1225 const Opbyte *program_ptr,
1231 case Bsave_excursion:
1232 record_unwind_protect (save_excursion_restore,
1233 save_excursion_save ());
1236 case Bsave_window_excursion:
1238 int count = specpdl_depth ();
1239 record_unwind_protect (save_window_excursion_unwind,
1240 Fcurrent_window_configuration (Qnil));
1242 unbind_to (count, Qnil);
1246 case Bsave_restriction:
1247 record_unwind_protect (save_restriction_restore,
1248 save_restriction_save ());
1253 Lisp_Object arg = POP;
1254 TOP = internal_catch (TOP, Feval, arg, 0);
1258 case Bskip_chars_backward:
1260 Lisp_Object arg = POP;
1261 TOP = Fskip_chars_backward (TOP, arg, Qnil);
1265 case Bunwind_protect:
1266 record_unwind_protect (Fprogn, POP);
1269 case Bcondition_case:
1271 Lisp_Object arg2 = POP; /* handlers */
1272 Lisp_Object arg1 = POP; /* bodyform */
1273 TOP = condition_case_3 (arg1, TOP, arg2);
1279 Lisp_Object arg2 = POP;
1280 Lisp_Object arg1 = POP;
1281 TOP = Fset_marker (TOP, arg1, arg2);
1287 Lisp_Object arg = POP;
1288 TOP = Frem (TOP, arg);
1292 case Bmatch_beginning:
1293 TOP = Fmatch_beginning (TOP);
1297 TOP = Fmatch_end (TOP);
1301 TOP = Fupcase (TOP, Qnil);
1305 TOP = Fdowncase (TOP, Qnil);
1310 Lisp_Object arg = POP;
1311 TOP = Ffset (TOP, arg);
1317 Lisp_Object arg = POP;
1318 TOP = Fstring_equal (TOP, arg);
1324 Lisp_Object arg = POP;
1325 TOP = Fstring_lessp (TOP, arg);
1331 Lisp_Object arg2 = POP;
1332 Lisp_Object arg1 = POP;
1333 TOP = Fsubstring (TOP, arg1, arg2);
1337 case Bcurrent_column:
1338 PUSH (make_int (current_column (current_buffer)));
1342 TOP = Fchar_after (TOP, Qnil);
1346 TOP = Findent_to (TOP, Qnil, Qnil);
1350 PUSH (Fwiden (Qnil));
1353 case Bfollowing_char:
1354 PUSH (Ffollowing_char (Qnil));
1357 case Bpreceding_char:
1358 PUSH (Fpreceding_char (Qnil));
1362 PUSH (Feolp (Qnil));
1366 PUSH (Feobp (Qnil));
1370 PUSH (Fbolp (Qnil));
1374 PUSH (Fbobp (Qnil));
1377 case Bsave_current_buffer:
1378 record_unwind_protect (save_current_buffer_restore,
1379 Fcurrent_buffer ());
1382 case Binteractive_p:
1383 PUSH (Finteractive_p ());
1387 TOP = Fforward_char (TOP, Qnil);
1391 TOP = Fforward_word (TOP, Qnil);
1395 TOP = Fforward_line (TOP, Qnil);
1399 TOP = Fchar_syntax (TOP, Qnil);
1402 case Bbuffer_substring:
1404 Lisp_Object arg = POP;
1405 TOP = Fbuffer_substring (TOP, arg, Qnil);
1409 case Bdelete_region:
1411 Lisp_Object arg = POP;
1412 TOP = Fdelete_region (TOP, arg, Qnil);
1416 case Bnarrow_to_region:
1418 Lisp_Object arg = POP;
1419 TOP = Fnarrow_to_region (TOP, arg, Qnil);
1424 TOP = Fend_of_line (TOP, Qnil);
1427 case Btemp_output_buffer_setup:
1428 temp_output_buffer_setup (TOP);
1429 TOP = Vstandard_output;
1432 case Btemp_output_buffer_show:
1434 Lisp_Object arg = POP;
1435 temp_output_buffer_show (TOP, Qnil);
1438 /* pop binding of standard-output */
1439 unbind_to (specpdl_depth() - 1, Qnil);
1445 Lisp_Object arg = POP;
1446 TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
1452 Lisp_Object arg = POP;
1453 TOP = Fold_memq (TOP, arg);
1459 Lisp_Object arg = POP;
1460 TOP = Fold_equal (TOP, arg);
1466 Lisp_Object arg = POP;
1467 TOP = Fold_member (TOP, arg);
1473 Lisp_Object arg = POP;
1474 TOP = Fold_assq (TOP, arg);
1487 invalid_byte_code_error (char *error_message, ...)
1491 char *buf = alloca_array (char, strlen (error_message) + 128);
1493 sprintf (buf, "%s", error_message);
1494 va_start (args, error_message);
1495 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (buf), Qnil, -1,
1499 signal_error (Qinvalid_byte_code, list1 (obj));
1502 /* Check for valid opcodes. Change this when adding new opcodes. */
1504 check_opcode (Opcode opcode)
1506 if ((opcode < Bvarref) ||
1508 (opcode > Bassq && opcode < Bconstant))
1509 invalid_byte_code_error
1510 ("invalid opcode %d in instruction stream", opcode);
1513 /* Check that IDX is a valid offset into the `constants' vector */
1515 check_constants_index (int idx, Lisp_Object constants)
1517 if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
1518 invalid_byte_code_error
1519 ("reference %d to constants array out of range 0, %d",
1520 idx, XVECTOR_LENGTH (constants) - 1);
1523 /* Get next character from Lisp instructions string. */
1524 #define READ_INSTRUCTION_CHAR(lvalue) do { \
1525 (lvalue) = charptr_emchar (ptr); \
1526 INC_CHARPTR (ptr); \
1527 *icounts_ptr++ = program_ptr - program; \
1528 if (lvalue > UCHAR_MAX) \
1529 invalid_byte_code_error \
1530 ("Invalid character %c in byte code string"); \
1533 /* Get opcode from Lisp instructions string. */
1534 #define READ_OPCODE do { \
1536 READ_INSTRUCTION_CHAR (c); \
1537 opcode = (Opcode) c; \
1540 /* Get next operand, a uint8, from Lisp instructions string. */
1541 #define READ_OPERAND_1 do { \
1542 READ_INSTRUCTION_CHAR (arg); \
1546 /* Get next operand, a uint16, from Lisp instructions string. */
1547 #define READ_OPERAND_2 do { \
1548 unsigned int arg1, arg2; \
1549 READ_INSTRUCTION_CHAR (arg1); \
1550 READ_INSTRUCTION_CHAR (arg2); \
1551 arg = arg1 + (arg2 << 8); \
1555 /* Write 1 byte to PTR, incrementing PTR */
1556 #define WRITE_INT8(value, ptr) do { \
1557 *((ptr)++) = (value); \
1560 /* Write 2 bytes to PTR, incrementing PTR */
1561 #define WRITE_INT16(value, ptr) do { \
1562 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \
1563 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \
1566 /* We've changed our minds about the opcode we've already written. */
1567 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
1569 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
1570 #define WRITE_NARGS(base_opcode) do { \
1573 REWRITE_OPCODE (base_opcode + arg); \
1575 else if (arg <= UCHAR_MAX) \
1577 REWRITE_OPCODE (base_opcode + 6); \
1578 WRITE_INT8 (arg, program_ptr); \
1582 REWRITE_OPCODE (base_opcode + 7); \
1583 WRITE_INT16 (arg, program_ptr); \
1587 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
1588 #define WRITE_CONSTANT do { \
1589 check_constants_index(arg, constants); \
1590 if (arg <= UCHAR_MAX - Bconstant) \
1592 REWRITE_OPCODE (Bconstant + arg); \
1596 REWRITE_OPCODE (Bconstant2); \
1597 WRITE_INT16 (arg, program_ptr); \
1601 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
1603 /* Compile byte code instructions into free space provided by caller, with
1604 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
1605 Returns length of compiled code. */
1607 optimize_byte_code (/* in */
1608 Lisp_Object instructions,
1609 Lisp_Object constants,
1611 Opbyte * const program,
1612 int * const program_length,
1613 int * const varbind_count)
1615 size_t instructions_length = XSTRING_LENGTH (instructions);
1616 size_t comfy_size = 2 * instructions_length;
1618 int * const icounts = alloca_array (int, comfy_size);
1619 int * icounts_ptr = icounts;
1621 /* We maintain a table of jumps in the source code. */
1627 struct jump * const jumps = xnew_array (struct jump, comfy_size);
1628 struct jump *jumps_ptr = jumps;
1630 Opbyte *program_ptr = program;
1632 const Bufbyte *ptr = XSTRING_DATA (instructions);
1633 const Bufbyte * const end = ptr + instructions_length;
1649 case Bvarref+7: READ_OPERAND_2; goto do_varref;
1650 case Bvarref+6: READ_OPERAND_1; goto do_varref;
1651 case Bvarref: case Bvarref+1: case Bvarref+2:
1652 case Bvarref+3: case Bvarref+4: case Bvarref+5:
1653 arg = opcode - Bvarref;
1655 check_constants_index (arg, constants);
1656 val = XVECTOR_DATA (constants) [arg];
1658 invalid_byte_code_error ("variable reference to non-symbol %S", val);
1659 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1660 invalid_byte_code_error ("variable reference to constant symbol %s",
1661 string_data (XSYMBOL (val)->name));
1662 WRITE_NARGS (Bvarref);
1665 case Bvarset+7: READ_OPERAND_2; goto do_varset;
1666 case Bvarset+6: READ_OPERAND_1; goto do_varset;
1667 case Bvarset: case Bvarset+1: case Bvarset+2:
1668 case Bvarset+3: case Bvarset+4: case Bvarset+5:
1669 arg = opcode - Bvarset;
1671 check_constants_index (arg, constants);
1672 val = XVECTOR_DATA (constants) [arg];
1674 invalid_byte_code_error ("attempt to set non-symbol %S", val);
1675 if (EQ (val, Qnil) || EQ (val, Qt))
1676 invalid_byte_code_error ("attempt to set constant symbol %s",
1677 string_data (XSYMBOL (val)->name));
1678 /* Ignore assignments to keywords by converting to Bdiscard.
1679 For backward compatibility only - we'd like to make this an error. */
1680 if (SYMBOL_IS_KEYWORD (val))
1681 REWRITE_OPCODE (Bdiscard);
1683 WRITE_NARGS (Bvarset);
1686 case Bvarbind+7: READ_OPERAND_2; goto do_varbind;
1687 case Bvarbind+6: READ_OPERAND_1; goto do_varbind;
1688 case Bvarbind: case Bvarbind+1: case Bvarbind+2:
1689 case Bvarbind+3: case Bvarbind+4: case Bvarbind+5:
1690 arg = opcode - Bvarbind;
1693 check_constants_index (arg, constants);
1694 val = XVECTOR_DATA (constants) [arg];
1696 invalid_byte_code_error ("attempt to let-bind non-symbol %S", val);
1697 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1698 invalid_byte_code_error ("attempt to let-bind constant symbol %s",
1699 string_data (XSYMBOL (val)->name));
1700 WRITE_NARGS (Bvarbind);
1703 case Bcall+7: READ_OPERAND_2; goto do_call;
1704 case Bcall+6: READ_OPERAND_1; goto do_call;
1705 case Bcall: case Bcall+1: case Bcall+2:
1706 case Bcall+3: case Bcall+4: case Bcall+5:
1707 arg = opcode - Bcall;
1709 WRITE_NARGS (Bcall);
1712 case Bunbind+7: READ_OPERAND_2; goto do_unbind;
1713 case Bunbind+6: READ_OPERAND_1; goto do_unbind;
1714 case Bunbind: case Bunbind+1: case Bunbind+2:
1715 case Bunbind+3: case Bunbind+4: case Bunbind+5:
1716 arg = opcode - Bunbind;
1718 WRITE_NARGS (Bunbind);
1724 case Bgotoifnilelsepop:
1725 case Bgotoifnonnilelsepop:
1727 /* Make program_ptr-relative */
1728 arg += icounts - (icounts_ptr - argsize);
1733 case BRgotoifnonnil:
1734 case BRgotoifnilelsepop:
1735 case BRgotoifnonnilelsepop:
1737 /* Make program_ptr-relative */
1740 /* Record program-relative goto addresses in `jumps' table */
1741 jumps_ptr->from = icounts_ptr - icounts - argsize;
1742 jumps_ptr->to = jumps_ptr->from + arg;
1744 if (arg >= -1 && arg <= argsize)
1745 invalid_byte_code_error
1746 ("goto instruction is its own target");
1747 if (arg <= SCHAR_MIN ||
1751 REWRITE_OPCODE (opcode + Bgoto - BRgoto);
1752 WRITE_INT16 (arg, program_ptr);
1757 REWRITE_OPCODE (opcode + BRgoto - Bgoto);
1758 WRITE_INT8 (arg, program_ptr);
1771 WRITE_INT8 (arg, program_ptr);
1775 if (opcode < Bconstant)
1776 check_opcode (opcode);
1779 arg = opcode - Bconstant;
1786 /* Fix up jumps table to refer to NEW offsets. */
1789 for (j = jumps; j < jumps_ptr; j++)
1791 #ifdef ERROR_CHECK_BYTE_CODE
1792 assert (j->from < icounts_ptr - icounts);
1793 assert (j->to < icounts_ptr - icounts);
1795 j->from = icounts[j->from];
1796 j->to = icounts[j->to];
1797 #ifdef ERROR_CHECK_BYTE_CODE
1798 assert (j->from < program_ptr - program);
1799 assert (j->to < program_ptr - program);
1800 check_opcode ((Opcode) (program[j->from-1]));
1802 check_opcode ((Opcode) (program[j->to]));
1806 /* Fixup jumps in byte-code until no more fixups needed */
1808 int more_fixups_needed = 1;
1810 while (more_fixups_needed)
1813 more_fixups_needed = 0;
1814 for (j = jumps; j < jumps_ptr; j++)
1818 int jump = to - from;
1819 Opbyte *p = program + from;
1820 Opcode opcode = (Opcode) p[-1];
1821 if (!more_fixups_needed)
1822 check_opcode ((Opcode) p[jump]);
1823 assert (to >= 0 && program + to < program_ptr);
1829 case Bgotoifnilelsepop:
1830 case Bgotoifnonnilelsepop:
1831 WRITE_INT16 (jump, p);
1836 case BRgotoifnonnil:
1837 case BRgotoifnilelsepop:
1838 case BRgotoifnonnilelsepop:
1839 if (jump > SCHAR_MIN &&
1842 WRITE_INT8 (jump, p);
1847 for (jj = jumps; jj < jumps_ptr; jj++)
1849 assert (jj->from < program_ptr - program);
1850 assert (jj->to < program_ptr - program);
1851 if (jj->from > from) jj->from++;
1852 if (jj->to > from) jj->to++;
1854 p[-1] += Bgoto - BRgoto;
1855 more_fixups_needed = 1;
1856 memmove (p+1, p, program_ptr++ - p);
1857 WRITE_INT16 (jump, p);
1869 /* *program_ptr++ = 0; */
1870 *program_length = program_ptr - program;
1874 /* Optimize the byte code and store the optimized program, only
1875 understood by bytecode.c, in an opaque object in the
1876 instructions slot of the Compiled_Function object. */
1878 optimize_compiled_function (Lisp_Object compiled_function)
1880 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
1885 /* If we have not actually read the bytecode string
1886 and constants vector yet, fetch them from the file. */
1887 if (CONSP (f->instructions))
1888 Ffetch_bytecode (compiled_function);
1890 if (STRINGP (f->instructions))
1892 /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1893 which would be slightly more `proper' */
1894 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
1895 optimize_byte_code (f->instructions, f->constants,
1896 program, &program_length, &varbind_count);
1897 f->specpdl_depth = (unsigned short) (XINT (Flength (f->arglist)) +
1900 make_opaque (program, program_length * sizeof (Opbyte));
1903 assert (OPAQUEP (f->instructions));
1906 /************************************************************************/
1907 /* The compiled-function object type */
1908 /************************************************************************/
1910 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
1913 /* This function can GC */
1914 Lisp_Compiled_Function *f =
1915 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
1916 int docp = f->flags.documentationp;
1917 int intp = f->flags.interactivep;
1918 struct gcpro gcpro1, gcpro2;
1920 GCPRO2 (obj, printcharfun);
1922 write_c_string (print_readably ? "#[" : "#<compiled-function ", printcharfun);
1923 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1924 if (!print_readably)
1926 Lisp_Object ann = compiled_function_annotation (f);
1929 write_c_string ("(from ", printcharfun);
1930 print_internal (ann, printcharfun, 1);
1931 write_c_string (") ", printcharfun);
1934 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1935 /* COMPILED_ARGLIST = 0 */
1936 print_internal (compiled_function_arglist (f), printcharfun, escapeflag);
1938 /* COMPILED_INSTRUCTIONS = 1 */
1939 write_c_string (" ", printcharfun);
1941 struct gcpro ngcpro1;
1942 Lisp_Object instructions = compiled_function_instructions (f);
1943 NGCPRO1 (instructions);
1944 if (STRINGP (instructions) && !print_readably)
1946 /* We don't usually want to see that junk in the bytecode. */
1947 sprintf (buf, "\"...(%ld)\"",
1948 (long) XSTRING_CHAR_LENGTH (instructions));
1949 write_c_string (buf, printcharfun);
1952 print_internal (instructions, printcharfun, escapeflag);
1956 /* COMPILED_CONSTANTS = 2 */
1957 write_c_string (" ", printcharfun);
1958 print_internal (compiled_function_constants (f), printcharfun, escapeflag);
1960 /* COMPILED_STACK_DEPTH = 3 */
1961 sprintf (buf, " %d", compiled_function_stack_depth (f));
1962 write_c_string (buf, printcharfun);
1964 /* COMPILED_DOC_STRING = 4 */
1967 write_c_string (" ", printcharfun);
1968 print_internal (compiled_function_documentation (f), printcharfun,
1972 /* COMPILED_INTERACTIVE = 5 */
1975 write_c_string (" ", printcharfun);
1976 print_internal (compiled_function_interactive (f), printcharfun,
1981 write_c_string (print_readably ? "]" : ">", printcharfun);
1986 mark_compiled_function (Lisp_Object obj)
1988 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1990 mark_object (f->instructions);
1991 mark_object (f->arglist);
1992 mark_object (f->doc_and_interactive);
1993 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1994 mark_object (f->annotated);
1996 /* tail-recurse on constants */
1997 return f->constants;
2001 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2003 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1);
2004 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
2006 (f1->flags.documentationp == f2->flags.documentationp &&
2007 f1->flags.interactivep == f2->flags.interactivep &&
2008 f1->flags.domainp == f2->flags.domainp && /* I18N3 */
2009 internal_equal (compiled_function_instructions (f1),
2010 compiled_function_instructions (f2), depth + 1) &&
2011 internal_equal (f1->constants, f2->constants, depth + 1) &&
2012 internal_equal (f1->arglist, f2->arglist, depth + 1) &&
2013 internal_equal (f1->doc_and_interactive,
2014 f2->doc_and_interactive, depth + 1));
2017 static unsigned long
2018 compiled_function_hash (Lisp_Object obj, int depth)
2020 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
2021 return HASH3 ((f->flags.documentationp << 2) +
2022 (f->flags.interactivep << 1) +
2024 internal_hash (f->instructions, depth + 1),
2025 internal_hash (f->constants, depth + 1));
2028 static const struct lrecord_description compiled_function_description[] = {
2029 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
2030 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
2031 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
2032 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
2033 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2034 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
2039 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
2040 mark_compiled_function,
2041 print_compiled_function, 0,
2042 compiled_function_equal,
2043 compiled_function_hash,
2044 compiled_function_description,
2045 Lisp_Compiled_Function);
2047 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
2048 Return t if OBJECT is a byte-compiled function object.
2052 return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
2055 /************************************************************************/
2056 /* compiled-function object accessor functions */
2057 /************************************************************************/
2060 compiled_function_arglist (Lisp_Compiled_Function *f)
2066 compiled_function_instructions (Lisp_Compiled_Function *f)
2068 if (! OPAQUEP (f->instructions))
2069 return f->instructions;
2072 /* Invert action performed by optimize_byte_code() */
2073 Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2075 Bufbyte * const buffer =
2076 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2077 Bufbyte *bp = buffer;
2079 const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
2080 const Opbyte *program_ptr = program;
2081 const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);
2083 while (program_ptr < program_end)
2085 Opcode opcode = (Opcode) READ_UINT_1;
2086 bp += set_charptr_emchar (bp, opcode);
2095 bp += set_charptr_emchar (bp, READ_UINT_1);
2096 bp += set_charptr_emchar (bp, READ_UINT_1);
2107 bp += set_charptr_emchar (bp, READ_UINT_1);
2113 case Bgotoifnilelsepop:
2114 case Bgotoifnonnilelsepop:
2116 int jump = READ_INT_2;
2118 Opbyte *buf2p = buf2;
2119 /* Convert back to program-relative address */
2120 WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
2121 bp += set_charptr_emchar (bp, buf2[0]);
2122 bp += set_charptr_emchar (bp, buf2[1]);
2128 case BRgotoifnonnil:
2129 case BRgotoifnilelsepop:
2130 case BRgotoifnonnilelsepop:
2131 bp += set_charptr_emchar (bp, READ_INT_1 + 127);
2138 return make_string (buffer, bp - buffer);
2143 compiled_function_constants (Lisp_Compiled_Function *f)
2145 return f->constants;
2149 compiled_function_stack_depth (Lisp_Compiled_Function *f)
2151 return f->stack_depth;
2154 /* The compiled_function->doc_and_interactive slot uses the minimal
2155 number of conses, based on compiled_function->flags; it may take
2156 any of the following forms:
2163 (interactive . domain)
2164 (doc . (interactive . domain))
2167 /* Caller must check flags.interactivep first */
2169 compiled_function_interactive (Lisp_Compiled_Function *f)
2171 assert (f->flags.interactivep);
2172 if (f->flags.documentationp && f->flags.domainp)
2173 return XCAR (XCDR (f->doc_and_interactive));
2174 else if (f->flags.documentationp)
2175 return XCDR (f->doc_and_interactive);
2176 else if (f->flags.domainp)
2177 return XCAR (f->doc_and_interactive);
2179 return f->doc_and_interactive;
2182 /* Caller need not check flags.documentationp first */
2184 compiled_function_documentation (Lisp_Compiled_Function *f)
2186 if (! f->flags.documentationp)
2188 else if (f->flags.interactivep && f->flags.domainp)
2189 return XCAR (f->doc_and_interactive);
2190 else if (f->flags.interactivep)
2191 return XCAR (f->doc_and_interactive);
2192 else if (f->flags.domainp)
2193 return XCAR (f->doc_and_interactive);
2195 return f->doc_and_interactive;
2198 /* Caller need not check flags.domainp first */
2200 compiled_function_domain (Lisp_Compiled_Function *f)
2202 if (! f->flags.domainp)
2204 else if (f->flags.documentationp && f->flags.interactivep)
2205 return XCDR (XCDR (f->doc_and_interactive));
2206 else if (f->flags.documentationp)
2207 return XCDR (f->doc_and_interactive);
2208 else if (f->flags.interactivep)
2209 return XCDR (f->doc_and_interactive);
2211 return f->doc_and_interactive;
2214 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2217 compiled_function_annotation (Lisp_Compiled_Function *f)
2219 return f->annotated;
2224 /* used only by Snarf-documentation; there must be doc already. */
2226 set_compiled_function_documentation (Lisp_Compiled_Function *f,
2227 Lisp_Object new_doc)
2229 assert (f->flags.documentationp);
2230 assert (INTP (new_doc) || STRINGP (new_doc));
2232 if (f->flags.interactivep && f->flags.domainp)
2233 XCAR (f->doc_and_interactive) = new_doc;
2234 else if (f->flags.interactivep)
2235 XCAR (f->doc_and_interactive) = new_doc;
2236 else if (f->flags.domainp)
2237 XCAR (f->doc_and_interactive) = new_doc;
2239 f->doc_and_interactive = new_doc;
2243 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2244 Return the argument list of the compiled-function object FUNCTION.
2248 CHECK_COMPILED_FUNCTION (function);
2249 return compiled_function_arglist (XCOMPILED_FUNCTION (function));
2252 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
2253 Return the byte-opcode string of the compiled-function object FUNCTION.
2257 CHECK_COMPILED_FUNCTION (function);
2258 return compiled_function_instructions (XCOMPILED_FUNCTION (function));
2261 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
2262 Return the constants vector of the compiled-function object FUNCTION.
2266 CHECK_COMPILED_FUNCTION (function);
2267 return compiled_function_constants (XCOMPILED_FUNCTION (function));
2270 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2271 Return the maximum stack depth of the compiled-function object FUNCTION.
2275 CHECK_COMPILED_FUNCTION (function);
2276 return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
2279 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
2280 Return the doc string of the compiled-function object FUNCTION, if available.
2281 Functions that had their doc strings snarfed into the DOC file will have
2282 an integer returned instead of a string.
2286 CHECK_COMPILED_FUNCTION (function);
2287 return compiled_function_documentation (XCOMPILED_FUNCTION (function));
2290 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2291 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2292 If non-nil, the return value will be a list whose first element is
2293 `interactive' and whose second element is the interactive spec.
2297 CHECK_COMPILED_FUNCTION (function);
2298 return XCOMPILED_FUNCTION (function)->flags.interactivep
2299 ? list2 (Qinteractive,
2300 compiled_function_interactive (XCOMPILED_FUNCTION (function)))
2304 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2306 /* Remove the `xx' if you wish to restore this feature */
2307 xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2308 Return the annotation of the compiled-function object FUNCTION, or nil.
2309 The annotation is a piece of information indicating where this
2310 compiled-function object came from. Generally this will be
2311 a symbol naming a function; or a string naming a file, if the
2312 compiled-function object was not defined in a function; or nil,
2313 if the compiled-function object was not created as a result of
2318 CHECK_COMPILED_FUNCTION (function);
2319 return compiled_function_annotation (XCOMPILED_FUNCTION (function));
2322 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2324 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
2325 Return the domain of the compiled-function object FUNCTION, or nil.
2326 This is only meaningful if I18N3 was enabled when emacs was compiled.
2330 CHECK_COMPILED_FUNCTION (function);
2331 return XCOMPILED_FUNCTION (function)->flags.domainp
2332 ? compiled_function_domain (XCOMPILED_FUNCTION (function))
2338 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
2339 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2343 Lisp_Compiled_Function *f;
2344 CHECK_COMPILED_FUNCTION (function);
2345 f = XCOMPILED_FUNCTION (function);
2347 if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
2350 if (CONSP (f->instructions))
2352 Lisp_Object tem = read_doc_string (f->instructions);
2354 signal_simple_error ("Invalid lazy-loaded byte code", tem);
2355 /* v18 or v19 bytecode file. Need to Ebolify. */
2356 if (f->flags.ebolified && VECTORP (XCDR (tem)))
2357 ebolify_bytecode_constants (XCDR (tem));
2358 f->instructions = XCAR (tem);
2359 f->constants = XCDR (tem);
2363 return Qnil; /* not reached */
2366 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
2367 Convert compiled function FUNCTION into an optimized internal form.
2371 Lisp_Compiled_Function *f;
2372 CHECK_COMPILED_FUNCTION (function);
2373 f = XCOMPILED_FUNCTION (function);
2375 if (OPAQUEP (f->instructions)) /* Already optimized? */
2378 optimize_compiled_function (function);
2382 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
2383 Function used internally in byte-compiled code.
2384 First argument INSTRUCTIONS is a string of byte code.
2385 Second argument CONSTANTS is a vector of constants.
2386 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2387 If STACK-DEPTH is incorrect, Emacs may crash.
2389 (instructions, constants, stack_depth))
2391 /* This function can GC */
2396 CHECK_STRING (instructions);
2397 CHECK_VECTOR (constants);
2398 CHECK_NATNUM (stack_depth);
2400 /* Optimize the `instructions' string, just like when executing a
2401 regular compiled function, but don't save it for later since this is
2402 likely to only be executed once. */
2403 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
2404 optimize_byte_code (instructions, constants, program,
2405 &program_length, &varbind_count);
2406 SPECPDL_RESERVE (varbind_count);
2407 return execute_optimized_program (program,
2409 XVECTOR_DATA (constants));
2414 syms_of_bytecode (void)
2416 INIT_LRECORD_IMPLEMENTATION (compiled_function);
2418 DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state);
2419 defsymbol (&Qbyte_code, "byte-code");
2420 defsymbol (&Qcompiled_functionp, "compiled-function-p");
2422 DEFSUBR (Fbyte_code);
2423 DEFSUBR (Ffetch_bytecode);
2424 DEFSUBR (Foptimize_compiled_function);
2426 DEFSUBR (Fcompiled_function_p);
2427 DEFSUBR (Fcompiled_function_instructions);
2428 DEFSUBR (Fcompiled_function_constants);
2429 DEFSUBR (Fcompiled_function_stack_depth);
2430 DEFSUBR (Fcompiled_function_arglist);
2431 DEFSUBR (Fcompiled_function_interactive);
2432 DEFSUBR (Fcompiled_function_doc_string);
2433 DEFSUBR (Fcompiled_function_domain);
2434 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2435 DEFSUBR (Fcompiled_function_annotation);
2438 #ifdef BYTE_CODE_METER
2439 defsymbol (&Qbyte_code_meter, "byte-code-meter");
2444 vars_of_bytecode (void)
2446 #ifdef BYTE_CODE_METER
2448 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
2449 A vector of vectors which holds a histogram of byte code usage.
2450 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2451 opcode CODE has been executed.
2452 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2453 indicates how many times the byte opcodes CODE1 and CODE2 have been
2454 executed in succession.
2456 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /*
2457 If non-nil, keep profiling information on byte code usage.
2458 The variable `byte-code-meter' indicates how often each byte opcode is used.
2459 If a symbol has a property named `byte-code-meter' whose value is an
2460 integer, it is incremented each time that symbol's function is called.
2463 byte_metering_on = 0;
2464 Vbyte_code_meter = make_vector (256, Qzero);
2468 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
2470 #endif /* BYTE_CODE_METER */