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 invalid_byte_code_error (char *error_message, ...);
216 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
217 const Opbyte *program_ptr,
220 static Lisp_Object execute_optimized_program (const Opbyte *program,
222 Lisp_Object *constants_data);
224 extern Lisp_Object Qand_rest, Qand_optional;
226 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
227 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
228 /* #define BYTE_CODE_METER */
231 #ifdef BYTE_CODE_METER
233 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
234 int byte_metering_on;
237 meter_code (Opcode prev_opcode, Opcode this_opcode)
239 if (byte_metering_on)
241 Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]);
242 p[0] = INT_PLUS1 (p[0]);
244 p[prev_opcode] = INT_PLUS1 (p[prev_opcode]);
248 #endif /* BYTE_CODE_METER */
252 bytecode_negate (Lisp_Object obj)
256 if (INTP (obj)) return make_int (- XINT (obj));
257 #ifdef LISP_FLOAT_TYPE
258 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
260 if (CHARP (obj)) return make_int (- ((int) XCHAR (obj)));
261 if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));
263 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
268 bytecode_nreverse (Lisp_Object list)
270 REGISTER Lisp_Object prev = Qnil;
271 REGISTER Lisp_Object tail = list;
275 REGISTER Lisp_Object next;
286 /* We have our own two-argument versions of various arithmetic ops.
287 Only two-argument arithmetic operations have their own byte codes. */
289 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2)
293 #ifdef LISP_FLOAT_TYPE
295 EMACS_INT ival1, ival2;
297 if (INTP (obj1)) ival1 = XINT (obj1);
298 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
299 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
300 else goto arithcompare_float;
302 if (INTP (obj2)) ival2 = XINT (obj2);
303 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
304 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
305 else goto arithcompare_float;
307 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
315 if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1);
316 else if (INTP (obj1)) dval1 = (double) XINT (obj1);
317 else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1);
318 else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1);
321 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
325 if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2);
326 else if (INTP (obj2)) dval2 = (double) XINT (obj2);
327 else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2);
328 else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2);
331 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
335 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
337 #else /* !LISP_FLOAT_TYPE */
339 EMACS_INT ival1, ival2;
341 if (INTP (obj1)) ival1 = XINT (obj1);
342 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
343 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
346 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
350 if (INTP (obj2)) ival2 = XINT (obj2);
351 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
352 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
355 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
359 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
361 #endif /* !LISP_FLOAT_TYPE */
365 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
367 #ifdef LISP_FLOAT_TYPE
368 EMACS_INT ival1, ival2;
375 if (INTP (obj1)) ival1 = XINT (obj1);
376 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
377 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
378 else if (FLOATP (obj1)) ival1 = 0, float_p = 1;
381 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
385 if (INTP (obj2)) ival2 = XINT (obj2);
386 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
387 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
388 else if (FLOATP (obj2)) ival2 = 0, float_p = 1;
391 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
399 case Bplus: ival1 += ival2; break;
400 case Bdiff: ival1 -= ival2; break;
401 case Bmult: ival1 *= ival2; break;
403 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
406 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
407 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
409 return make_int (ival1);
413 double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1;
414 double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2;
417 case Bplus: dval1 += dval2; break;
418 case Bdiff: dval1 -= dval2; break;
419 case Bmult: dval1 *= dval2; break;
421 if (dval2 == 0) Fsignal (Qarith_error, Qnil);
424 case Bmax: if (dval1 < dval2) dval1 = dval2; break;
425 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
427 return make_float (dval1);
429 #else /* !LISP_FLOAT_TYPE */
430 EMACS_INT ival1, ival2;
434 if (INTP (obj1)) ival1 = XINT (obj1);
435 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
436 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
439 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
443 if (INTP (obj2)) ival2 = XINT (obj2);
444 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
445 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
448 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
454 case Bplus: ival1 += ival2; break;
455 case Bdiff: ival1 -= ival2; break;
456 case Bmult: ival1 *= ival2; break;
458 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
461 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
462 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
464 return make_int (ival1);
465 #endif /* !LISP_FLOAT_TYPE */
468 /* Apply compiled-function object FUN to the NARGS evaluated arguments
469 in ARGS, and return the result of evaluation. */
471 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[])
473 /* This function can GC */
474 int speccount = specpdl_depth();
476 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
479 if (!OPAQUEP (f->instructions))
480 /* Lazily munge the instructions into a more efficient form */
481 optimize_compiled_function (fun);
483 /* optimize_compiled_function() guaranteed that f->specpdl_depth is
484 the required space on the specbinding stack for binding the args
485 and local variables of fun. So just reserve it once. */
486 SPECPDL_RESERVE (f->specpdl_depth);
489 /* Fmake_byte_code() guaranteed that f->arglist is a valid list
490 containing only non-constant symbols. */
491 LIST_LOOP_3 (symbol, f->arglist, tail)
493 if (EQ (symbol, Qand_rest))
496 symbol = XCAR (tail);
497 SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i]));
500 else if (EQ (symbol, Qand_optional))
502 else if (i == nargs && !optional)
503 goto wrong_number_of_arguments;
505 SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil);
510 goto wrong_number_of_arguments;
516 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions),
518 XVECTOR_DATA (f->constants));
520 /* The attempt to optimize this by only unbinding variables failed
521 because using buffer-local variables as function parameters
522 leads to specpdl_ptr->func != 0 */
523 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */
524 UNBIND_TO_GCPRO (speccount, value);
528 wrong_number_of_arguments:
529 /* The actual printed compiled_function object is incomprehensible.
530 Check the backtrace to see if we can get a more meaningful symbol. */
531 if (EQ (fun, indirect_function (*backtrace_list->function, 0)))
532 fun = *backtrace_list->function;
533 return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
537 /* Read next uint8 from the instruction stream. */
538 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
540 /* Read next uint16 from the instruction stream. */
541 #define READ_UINT_2 \
543 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \
544 ((unsigned int) (unsigned char) program_ptr[-2])))
546 /* Read next int8 from the instruction stream. */
547 #define READ_INT_1 ((int) (signed char) *program_ptr++)
549 /* Read next int16 from the instruction stream. */
552 (((int) ( signed char) program_ptr[-1]) * 256 + \
553 ((int) (unsigned char) program_ptr[-2])))
555 /* Read next int8 from instruction stream; don't advance program_pointer */
556 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
558 /* Read next int16 from instruction stream; don't advance program_pointer */
560 ((((int) ( signed char) program_ptr[1]) * 256) | \
561 ((int) (unsigned char) program_ptr[0]))
563 /* Do relative jumps from the current location.
564 We only do a QUIT if we jump backwards, for efficiency.
565 No infloops without backward jumps! */
566 #define JUMP_RELATIVE(jump) do { \
567 int JR_jump = (jump); \
568 if (JR_jump < 0) QUIT; \
569 program_ptr += JR_jump; \
572 #define JUMP JUMP_RELATIVE (PEEK_INT_2)
573 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
575 #define JUMP_NEXT ((void) (program_ptr += 2))
576 #define JUMPR_NEXT ((void) (program_ptr += 1))
578 /* Push x onto the execution stack. */
579 #define PUSH(x) (*++stack_ptr = (x))
581 /* Pop a value off the execution stack. */
582 #define POP (*stack_ptr--)
584 /* Discard n values from the execution stack. */
585 #define DISCARD(n) (stack_ptr -= (n))
587 /* Get the value which is at the top of the execution stack,
589 #define TOP (*stack_ptr)
591 /* The actual interpreter for byte code.
592 This function has been seriously optimized for performance.
593 Don't change the constructs unless you are willing to do
594 real benchmarking and profiling work -- martin */
598 execute_optimized_program (const Opbyte *program,
600 Lisp_Object *constants_data)
602 /* This function can GC */
603 REGISTER const Opbyte *program_ptr = (Opbyte *) program;
604 REGISTER Lisp_Object *stack_ptr
605 = alloca_array (Lisp_Object, stack_depth + 1);
606 int speccount = specpdl_depth ();
609 #ifdef BYTE_CODE_METER
610 Opcode this_opcode = 0;
614 #ifdef ERROR_CHECK_BYTE_CODE
615 Lisp_Object *stack_beg = stack_ptr;
616 Lisp_Object *stack_end = stack_beg + stack_depth;
619 /* Initialize all the objects on the stack to Qnil,
620 so we can GCPRO the whole stack.
621 The first element of the stack is actually a dummy. */
625 for (i = stack_depth, p = stack_ptr; i--;)
629 GCPRO1 (stack_ptr[1]);
630 gcpro1.nvars = stack_depth;
634 REGISTER Opcode opcode = (Opcode) READ_UINT_1;
635 #ifdef ERROR_CHECK_BYTE_CODE
636 if (stack_ptr > stack_end)
637 invalid_byte_code_error ("byte code stack overflow");
638 if (stack_ptr < stack_beg)
639 invalid_byte_code_error ("byte code stack underflow");
642 #ifdef BYTE_CODE_METER
643 prev_opcode = this_opcode;
644 this_opcode = opcode;
645 meter_code (prev_opcode, this_opcode);
653 if (opcode >= Bconstant)
654 PUSH (constants_data[opcode - Bconstant]);
656 stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode);
664 case Bvarref+5: n = opcode - Bvarref; goto do_varref;
665 case Bvarref+7: n = READ_UINT_2; goto do_varref;
666 case Bvarref+6: n = READ_UINT_1; /* most common */
669 Lisp_Object symbol = constants_data[n];
670 Lisp_Object value = XSYMBOL (symbol)->value;
671 if (SYMBOL_VALUE_MAGIC_P (value))
672 value = Fsymbol_value (symbol);
682 case Bvarset+5: n = opcode - Bvarset; goto do_varset;
683 case Bvarset+7: n = READ_UINT_2; goto do_varset;
684 case Bvarset+6: n = READ_UINT_1; /* most common */
687 Lisp_Object symbol = constants_data[n];
688 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
689 Lisp_Object old_value = symbol_ptr->value;
690 Lisp_Object new_value = POP;
691 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
692 symbol_ptr->value = new_value;
694 Fset (symbol, new_value);
703 case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind;
704 case Bvarbind+7: n = READ_UINT_2; goto do_varbind;
705 case Bvarbind+6: n = READ_UINT_1; /* most common */
708 Lisp_Object symbol = constants_data[n];
709 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
710 Lisp_Object old_value = symbol_ptr->value;
711 Lisp_Object new_value = POP;
712 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
714 specpdl_ptr->symbol = symbol;
715 specpdl_ptr->old_value = old_value;
716 specpdl_ptr->func = 0;
718 specpdl_depth_counter++;
720 symbol_ptr->value = new_value;
723 specbind_magic (symbol, new_value);
735 n = (opcode < Bcall+6 ? opcode - Bcall :
736 opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2);
738 #ifdef BYTE_CODE_METER
739 if (byte_metering_on && SYMBOLP (TOP))
741 Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
743 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
746 TOP = Ffuncall (n + 1, &TOP);
757 UNBIND_TO (specpdl_depth() -
758 (opcode < Bunbind+6 ? opcode-Bunbind :
759 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
781 case Bgotoifnilelsepop:
791 case Bgotoifnonnilelsepop:
820 case BRgotoifnilelsepop:
830 case BRgotoifnonnilelsepop:
842 #ifdef ERROR_CHECK_BYTE_CODE
843 /* Binds and unbinds are supposed to be compiled balanced. */
844 if (specpdl_depth() != speccount)
845 invalid_byte_code_error ("unbalanced specbinding stack");
855 Lisp_Object arg = TOP;
861 PUSH (constants_data[READ_UINT_2]);
865 TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
869 TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
874 /* To unbind back to the beginning of this frame. Not used yet,
875 but will be needed for tail-recursion elimination. */
876 unbind_to (speccount, Qnil);
881 Lisp_Object arg = POP;
882 TOP = Fcar (Fnthcdr (TOP, arg));
887 TOP = SYMBOLP (TOP) ? Qt : Qnil;
891 TOP = CONSP (TOP) ? Qt : Qnil;
895 TOP = STRINGP (TOP) ? Qt : Qnil;
899 TOP = LISTP (TOP) ? Qt : Qnil;
903 TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
907 TOP = INTP (TOP) ? Qt : Qnil;
912 Lisp_Object arg = POP;
913 TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
918 TOP = NILP (TOP) ? Qt : Qnil;
923 Lisp_Object arg = POP;
924 TOP = Fcons (TOP, arg);
929 TOP = Fcons (TOP, Qnil);
941 n = opcode - (Blist1 - 1);
944 Lisp_Object list = Qnil;
946 list = Fcons (TOP, list);
960 n = opcode - (Bconcat2 - 2);
968 TOP = Fconcat (n, &TOP);
978 Lisp_Object arg2 = POP;
979 Lisp_Object arg1 = POP;
980 TOP = Faset (TOP, arg1, arg2);
985 TOP = Fsymbol_value (TOP);
988 case Bsymbol_function:
989 TOP = Fsymbol_function (TOP);
994 Lisp_Object arg = POP;
995 TOP = Fget (TOP, arg, Qnil);
1000 TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
1004 TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
1010 Lisp_Object arg = POP;
1011 TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
1017 Lisp_Object arg = POP;
1018 TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
1024 Lisp_Object arg = POP;
1025 TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
1031 Lisp_Object arg = POP;
1032 TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
1038 Lisp_Object arg = POP;
1039 TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
1045 TOP = bytecode_negate (TOP);
1050 TOP = bytecode_nconc2 (&TOP);
1055 Lisp_Object arg2 = POP;
1056 Lisp_Object arg1 = TOP;
1057 TOP = INTP (arg1) && INTP (arg2) ?
1058 INT_PLUS (arg1, arg2) :
1059 bytecode_arithop (arg1, arg2, opcode);
1065 Lisp_Object arg2 = POP;
1066 Lisp_Object arg1 = TOP;
1067 TOP = INTP (arg1) && INTP (arg2) ?
1068 INT_MINUS (arg1, arg2) :
1069 bytecode_arithop (arg1, arg2, opcode);
1078 Lisp_Object arg = POP;
1079 TOP = bytecode_arithop (TOP, arg, opcode);
1084 PUSH (make_int (BUF_PT (current_buffer)));
1088 TOP = Finsert (1, &TOP);
1094 TOP = Finsert (n, &TOP);
1099 Lisp_Object arg = POP;
1100 TOP = Faref (TOP, arg);
1106 Lisp_Object arg = POP;
1107 TOP = Fmemq (TOP, arg);
1113 Lisp_Object arg = POP;
1114 TOP = Fset (TOP, arg);
1120 Lisp_Object arg = POP;
1121 TOP = Fequal (TOP, arg);
1127 Lisp_Object arg = POP;
1128 TOP = Fnthcdr (TOP, arg);
1134 Lisp_Object arg = POP;
1135 TOP = Felt (TOP, arg);
1141 Lisp_Object arg = POP;
1142 TOP = Fmember (TOP, arg);
1147 TOP = Fgoto_char (TOP, Qnil);
1150 case Bcurrent_buffer:
1153 XSETBUFFER (buffer, current_buffer);
1159 TOP = Fset_buffer (TOP);
1163 PUSH (make_int (BUF_ZV (current_buffer)));
1167 PUSH (make_int (BUF_BEGV (current_buffer)));
1170 case Bskip_chars_forward:
1172 Lisp_Object arg = POP;
1173 TOP = Fskip_chars_forward (TOP, arg, Qnil);
1179 Lisp_Object arg = POP;
1180 TOP = Fassq (TOP, arg);
1186 Lisp_Object arg = POP;
1187 TOP = Fsetcar (TOP, arg);
1193 Lisp_Object arg = POP;
1194 TOP = Fsetcdr (TOP, arg);
1199 TOP = bytecode_nreverse (TOP);
1203 TOP = CONSP (TOP) ? XCAR (TOP) : Qnil;
1207 TOP = CONSP (TOP) ? XCDR (TOP) : Qnil;
1214 /* It makes a worthwhile performance difference (5%) to shunt
1215 lesser-used opcodes off to a subroutine, to keep the switch in
1216 execute_optimized_program small. If you REALLY care about
1217 performance, you want to keep your heavily executed code away from
1218 rarely executed code, to minimize cache misses.
1220 Don't make this function static, since then the compiler might inline it. */
1222 execute_rare_opcode (Lisp_Object *stack_ptr,
1223 const Opbyte *program_ptr,
1229 case Bsave_excursion:
1230 record_unwind_protect (save_excursion_restore,
1231 save_excursion_save ());
1234 case Bsave_window_excursion:
1236 int count = specpdl_depth ();
1237 record_unwind_protect (save_window_excursion_unwind,
1238 Fcurrent_window_configuration (Qnil));
1240 unbind_to (count, Qnil);
1244 case Bsave_restriction:
1245 record_unwind_protect (save_restriction_restore,
1246 save_restriction_save ());
1251 Lisp_Object arg = POP;
1252 TOP = internal_catch (TOP, Feval, arg, 0);
1256 case Bskip_chars_backward:
1258 Lisp_Object arg = POP;
1259 TOP = Fskip_chars_backward (TOP, arg, Qnil);
1263 case Bunwind_protect:
1264 record_unwind_protect (Fprogn, POP);
1267 case Bcondition_case:
1269 Lisp_Object arg2 = POP; /* handlers */
1270 Lisp_Object arg1 = POP; /* bodyform */
1271 TOP = condition_case_3 (arg1, TOP, arg2);
1277 Lisp_Object arg2 = POP;
1278 Lisp_Object arg1 = POP;
1279 TOP = Fset_marker (TOP, arg1, arg2);
1285 Lisp_Object arg = POP;
1286 TOP = Frem (TOP, arg);
1290 case Bmatch_beginning:
1291 TOP = Fmatch_beginning (TOP);
1295 TOP = Fmatch_end (TOP);
1299 TOP = Fupcase (TOP, Qnil);
1303 TOP = Fdowncase (TOP, Qnil);
1308 Lisp_Object arg = POP;
1309 TOP = Ffset (TOP, arg);
1315 Lisp_Object arg = POP;
1316 TOP = Fstring_equal (TOP, arg);
1322 Lisp_Object arg = POP;
1323 TOP = Fstring_lessp (TOP, arg);
1329 Lisp_Object arg2 = POP;
1330 Lisp_Object arg1 = POP;
1331 TOP = Fsubstring (TOP, arg1, arg2);
1335 case Bcurrent_column:
1336 PUSH (make_int (current_column (current_buffer)));
1340 TOP = Fchar_after (TOP, Qnil);
1344 TOP = Findent_to (TOP, Qnil, Qnil);
1348 PUSH (Fwiden (Qnil));
1351 case Bfollowing_char:
1352 PUSH (Ffollowing_char (Qnil));
1355 case Bpreceding_char:
1356 PUSH (Fpreceding_char (Qnil));
1360 PUSH (Feolp (Qnil));
1364 PUSH (Feobp (Qnil));
1368 PUSH (Fbolp (Qnil));
1372 PUSH (Fbobp (Qnil));
1375 case Bsave_current_buffer:
1376 record_unwind_protect (save_current_buffer_restore,
1377 Fcurrent_buffer ());
1380 case Binteractive_p:
1381 PUSH (Finteractive_p ());
1385 TOP = Fforward_char (TOP, Qnil);
1389 TOP = Fforward_word (TOP, Qnil);
1393 TOP = Fforward_line (TOP, Qnil);
1397 TOP = Fchar_syntax (TOP, Qnil);
1400 case Bbuffer_substring:
1402 Lisp_Object arg = POP;
1403 TOP = Fbuffer_substring (TOP, arg, Qnil);
1407 case Bdelete_region:
1409 Lisp_Object arg = POP;
1410 TOP = Fdelete_region (TOP, arg, Qnil);
1414 case Bnarrow_to_region:
1416 Lisp_Object arg = POP;
1417 TOP = Fnarrow_to_region (TOP, arg, Qnil);
1422 TOP = Fend_of_line (TOP, Qnil);
1425 case Btemp_output_buffer_setup:
1426 temp_output_buffer_setup (TOP);
1427 TOP = Vstandard_output;
1430 case Btemp_output_buffer_show:
1432 Lisp_Object arg = POP;
1433 temp_output_buffer_show (TOP, Qnil);
1436 /* pop binding of standard-output */
1437 unbind_to (specpdl_depth() - 1, Qnil);
1443 Lisp_Object arg = POP;
1444 TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
1450 Lisp_Object arg = POP;
1451 TOP = Fold_memq (TOP, arg);
1457 Lisp_Object arg = POP;
1458 TOP = Fold_equal (TOP, arg);
1464 Lisp_Object arg = POP;
1465 TOP = Fold_member (TOP, arg);
1471 Lisp_Object arg = POP;
1472 TOP = Fold_assq (TOP, arg);
1485 invalid_byte_code_error (char *error_message, ...)
1489 char *buf = alloca_array (char, strlen (error_message) + 128);
1491 sprintf (buf, "%s", error_message);
1492 va_start (args, error_message);
1493 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (buf), Qnil, -1,
1497 signal_error (Qinvalid_byte_code, list1 (obj));
1500 /* Check for valid opcodes. Change this when adding new opcodes. */
1502 check_opcode (Opcode opcode)
1504 if ((opcode < Bvarref) ||
1506 (opcode > Bassq && opcode < Bconstant))
1507 invalid_byte_code_error
1508 ("invalid opcode %d in instruction stream", opcode);
1511 /* Check that IDX is a valid offset into the `constants' vector */
1513 check_constants_index (int idx, Lisp_Object constants)
1515 if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
1516 invalid_byte_code_error
1517 ("reference %d to constants array out of range 0, %d",
1518 idx, XVECTOR_LENGTH (constants) - 1);
1521 /* Get next character from Lisp instructions string. */
1522 #define READ_INSTRUCTION_CHAR(lvalue) do { \
1523 (lvalue) = charptr_emchar (ptr); \
1524 INC_CHARPTR (ptr); \
1525 *icounts_ptr++ = program_ptr - program; \
1526 if (lvalue > UCHAR_MAX) \
1527 invalid_byte_code_error \
1528 ("Invalid character %c in byte code string"); \
1531 /* Get opcode from Lisp instructions string. */
1532 #define READ_OPCODE do { \
1534 READ_INSTRUCTION_CHAR (c); \
1535 opcode = (Opcode) c; \
1538 /* Get next operand, a uint8, from Lisp instructions string. */
1539 #define READ_OPERAND_1 do { \
1540 READ_INSTRUCTION_CHAR (arg); \
1544 /* Get next operand, a uint16, from Lisp instructions string. */
1545 #define READ_OPERAND_2 do { \
1546 unsigned int arg1, arg2; \
1547 READ_INSTRUCTION_CHAR (arg1); \
1548 READ_INSTRUCTION_CHAR (arg2); \
1549 arg = arg1 + (arg2 << 8); \
1553 /* Write 1 byte to PTR, incrementing PTR */
1554 #define WRITE_INT8(value, ptr) do { \
1555 *((ptr)++) = (value); \
1558 /* Write 2 bytes to PTR, incrementing PTR */
1559 #define WRITE_INT16(value, ptr) do { \
1560 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \
1561 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \
1564 /* We've changed our minds about the opcode we've already written. */
1565 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
1567 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
1568 #define WRITE_NARGS(base_opcode) do { \
1571 REWRITE_OPCODE (base_opcode + arg); \
1573 else if (arg <= UCHAR_MAX) \
1575 REWRITE_OPCODE (base_opcode + 6); \
1576 WRITE_INT8 (arg, program_ptr); \
1580 REWRITE_OPCODE (base_opcode + 7); \
1581 WRITE_INT16 (arg, program_ptr); \
1585 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
1586 #define WRITE_CONSTANT do { \
1587 check_constants_index(arg, constants); \
1588 if (arg <= UCHAR_MAX - Bconstant) \
1590 REWRITE_OPCODE (Bconstant + arg); \
1594 REWRITE_OPCODE (Bconstant2); \
1595 WRITE_INT16 (arg, program_ptr); \
1599 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
1601 /* Compile byte code instructions into free space provided by caller, with
1602 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
1603 Returns length of compiled code. */
1605 optimize_byte_code (/* in */
1606 Lisp_Object instructions,
1607 Lisp_Object constants,
1609 Opbyte * const program,
1610 int * const program_length,
1611 int * const varbind_count)
1613 size_t instructions_length = XSTRING_LENGTH (instructions);
1614 size_t comfy_size = 2 * instructions_length;
1616 int * const icounts = alloca_array (int, comfy_size);
1617 int * icounts_ptr = icounts;
1619 /* We maintain a table of jumps in the source code. */
1625 struct jump * const jumps = alloca_array (struct jump, comfy_size);
1626 struct jump *jumps_ptr = jumps;
1628 Opbyte *program_ptr = program;
1630 const Bufbyte *ptr = XSTRING_DATA (instructions);
1631 const Bufbyte * const end = ptr + instructions_length;
1647 case Bvarref+7: READ_OPERAND_2; goto do_varref;
1648 case Bvarref+6: READ_OPERAND_1; goto do_varref;
1649 case Bvarref: case Bvarref+1: case Bvarref+2:
1650 case Bvarref+3: case Bvarref+4: case Bvarref+5:
1651 arg = opcode - Bvarref;
1653 check_constants_index (arg, constants);
1654 val = XVECTOR_DATA (constants) [arg];
1656 invalid_byte_code_error ("variable reference to non-symbol %S", val);
1657 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1658 invalid_byte_code_error ("variable reference to constant symbol %s",
1659 string_data (XSYMBOL (val)->name));
1660 WRITE_NARGS (Bvarref);
1663 case Bvarset+7: READ_OPERAND_2; goto do_varset;
1664 case Bvarset+6: READ_OPERAND_1; goto do_varset;
1665 case Bvarset: case Bvarset+1: case Bvarset+2:
1666 case Bvarset+3: case Bvarset+4: case Bvarset+5:
1667 arg = opcode - Bvarset;
1669 check_constants_index (arg, constants);
1670 val = XVECTOR_DATA (constants) [arg];
1672 invalid_byte_code_error ("attempt to set non-symbol %S", val);
1673 if (EQ (val, Qnil) || EQ (val, Qt))
1674 invalid_byte_code_error ("attempt to set constant symbol %s",
1675 string_data (XSYMBOL (val)->name));
1676 /* Ignore assignments to keywords by converting to Bdiscard.
1677 For backward compatibility only - we'd like to make this an error. */
1678 if (SYMBOL_IS_KEYWORD (val))
1679 REWRITE_OPCODE (Bdiscard);
1681 WRITE_NARGS (Bvarset);
1684 case Bvarbind+7: READ_OPERAND_2; goto do_varbind;
1685 case Bvarbind+6: READ_OPERAND_1; goto do_varbind;
1686 case Bvarbind: case Bvarbind+1: case Bvarbind+2:
1687 case Bvarbind+3: case Bvarbind+4: case Bvarbind+5:
1688 arg = opcode - Bvarbind;
1691 check_constants_index (arg, constants);
1692 val = XVECTOR_DATA (constants) [arg];
1694 invalid_byte_code_error ("attempt to let-bind non-symbol %S", val);
1695 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1696 invalid_byte_code_error ("attempt to let-bind constant symbol %s",
1697 string_data (XSYMBOL (val)->name));
1698 WRITE_NARGS (Bvarbind);
1701 case Bcall+7: READ_OPERAND_2; goto do_call;
1702 case Bcall+6: READ_OPERAND_1; goto do_call;
1703 case Bcall: case Bcall+1: case Bcall+2:
1704 case Bcall+3: case Bcall+4: case Bcall+5:
1705 arg = opcode - Bcall;
1707 WRITE_NARGS (Bcall);
1710 case Bunbind+7: READ_OPERAND_2; goto do_unbind;
1711 case Bunbind+6: READ_OPERAND_1; goto do_unbind;
1712 case Bunbind: case Bunbind+1: case Bunbind+2:
1713 case Bunbind+3: case Bunbind+4: case Bunbind+5:
1714 arg = opcode - Bunbind;
1716 WRITE_NARGS (Bunbind);
1722 case Bgotoifnilelsepop:
1723 case Bgotoifnonnilelsepop:
1725 /* Make program_ptr-relative */
1726 arg += icounts - (icounts_ptr - argsize);
1731 case BRgotoifnonnil:
1732 case BRgotoifnilelsepop:
1733 case BRgotoifnonnilelsepop:
1735 /* Make program_ptr-relative */
1738 /* Record program-relative goto addresses in `jumps' table */
1739 jumps_ptr->from = icounts_ptr - icounts - argsize;
1740 jumps_ptr->to = jumps_ptr->from + arg;
1742 if (arg >= -1 && arg <= argsize)
1743 invalid_byte_code_error
1744 ("goto instruction is its own target");
1745 if (arg <= SCHAR_MIN ||
1749 REWRITE_OPCODE (opcode + Bgoto - BRgoto);
1750 WRITE_INT16 (arg, program_ptr);
1755 REWRITE_OPCODE (opcode + BRgoto - Bgoto);
1756 WRITE_INT8 (arg, program_ptr);
1769 WRITE_INT8 (arg, program_ptr);
1773 if (opcode < Bconstant)
1774 check_opcode (opcode);
1777 arg = opcode - Bconstant;
1784 /* Fix up jumps table to refer to NEW offsets. */
1787 for (j = jumps; j < jumps_ptr; j++)
1789 #ifdef ERROR_CHECK_BYTE_CODE
1790 assert (j->from < icounts_ptr - icounts);
1791 assert (j->to < icounts_ptr - icounts);
1793 j->from = icounts[j->from];
1794 j->to = icounts[j->to];
1795 #ifdef ERROR_CHECK_BYTE_CODE
1796 assert (j->from < program_ptr - program);
1797 assert (j->to < program_ptr - program);
1798 check_opcode ((Opcode) (program[j->from-1]));
1800 check_opcode ((Opcode) (program[j->to]));
1804 /* Fixup jumps in byte-code until no more fixups needed */
1806 int more_fixups_needed = 1;
1808 while (more_fixups_needed)
1811 more_fixups_needed = 0;
1812 for (j = jumps; j < jumps_ptr; j++)
1816 int jump = to - from;
1817 Opbyte *p = program + from;
1818 Opcode opcode = (Opcode) p[-1];
1819 if (!more_fixups_needed)
1820 check_opcode ((Opcode) p[jump]);
1821 assert (to >= 0 && program + to < program_ptr);
1827 case Bgotoifnilelsepop:
1828 case Bgotoifnonnilelsepop:
1829 WRITE_INT16 (jump, p);
1834 case BRgotoifnonnil:
1835 case BRgotoifnilelsepop:
1836 case BRgotoifnonnilelsepop:
1837 if (jump > SCHAR_MIN &&
1840 WRITE_INT8 (jump, p);
1845 for (jj = jumps; jj < jumps_ptr; jj++)
1847 assert (jj->from < program_ptr - program);
1848 assert (jj->to < program_ptr - program);
1849 if (jj->from > from) jj->from++;
1850 if (jj->to > from) jj->to++;
1852 p[-1] += Bgoto - BRgoto;
1853 more_fixups_needed = 1;
1854 memmove (p+1, p, program_ptr++ - p);
1855 WRITE_INT16 (jump, p);
1867 /* *program_ptr++ = 0; */
1868 *program_length = program_ptr - program;
1871 /* Optimize the byte code and store the optimized program, only
1872 understood by bytecode.c, in an opaque object in the
1873 instructions slot of the Compiled_Function object. */
1875 optimize_compiled_function (Lisp_Object compiled_function)
1877 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
1882 /* If we have not actually read the bytecode string
1883 and constants vector yet, fetch them from the file. */
1884 if (CONSP (f->instructions))
1885 Ffetch_bytecode (compiled_function);
1887 if (STRINGP (f->instructions))
1889 /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1890 which would be slightly more `proper' */
1891 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
1892 optimize_byte_code (f->instructions, f->constants,
1893 program, &program_length, &varbind_count);
1894 f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
1896 make_opaque (program, program_length * sizeof (Opbyte));
1899 assert (OPAQUEP (f->instructions));
1902 /************************************************************************/
1903 /* The compiled-function object type */
1904 /************************************************************************/
1906 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
1909 /* This function can GC */
1910 Lisp_Compiled_Function *f =
1911 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
1912 int docp = f->flags.documentationp;
1913 int intp = f->flags.interactivep;
1914 struct gcpro gcpro1, gcpro2;
1916 GCPRO2 (obj, printcharfun);
1918 write_c_string (print_readably ? "#[" : "#<compiled-function ", printcharfun);
1919 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1920 if (!print_readably)
1922 Lisp_Object ann = compiled_function_annotation (f);
1925 write_c_string ("(from ", printcharfun);
1926 print_internal (ann, printcharfun, 1);
1927 write_c_string (") ", printcharfun);
1930 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1931 /* COMPILED_ARGLIST = 0 */
1932 print_internal (compiled_function_arglist (f), printcharfun, escapeflag);
1934 /* COMPILED_INSTRUCTIONS = 1 */
1935 write_c_string (" ", printcharfun);
1937 struct gcpro ngcpro1;
1938 Lisp_Object instructions = compiled_function_instructions (f);
1939 NGCPRO1 (instructions);
1940 if (STRINGP (instructions) && !print_readably)
1942 /* We don't usually want to see that junk in the bytecode. */
1943 sprintf (buf, "\"...(%ld)\"",
1944 (long) XSTRING_CHAR_LENGTH (instructions));
1945 write_c_string (buf, printcharfun);
1948 print_internal (instructions, printcharfun, escapeflag);
1952 /* COMPILED_CONSTANTS = 2 */
1953 write_c_string (" ", printcharfun);
1954 print_internal (compiled_function_constants (f), printcharfun, escapeflag);
1956 /* COMPILED_STACK_DEPTH = 3 */
1957 sprintf (buf, " %d", compiled_function_stack_depth (f));
1958 write_c_string (buf, printcharfun);
1960 /* COMPILED_DOC_STRING = 4 */
1963 write_c_string (" ", printcharfun);
1964 print_internal (compiled_function_documentation (f), printcharfun,
1968 /* COMPILED_INTERACTIVE = 5 */
1971 write_c_string (" ", printcharfun);
1972 print_internal (compiled_function_interactive (f), printcharfun,
1977 write_c_string (print_readably ? "]" : ">", printcharfun);
1982 mark_compiled_function (Lisp_Object obj)
1984 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1986 mark_object (f->instructions);
1987 mark_object (f->arglist);
1988 mark_object (f->doc_and_interactive);
1989 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1990 mark_object (f->annotated);
1992 /* tail-recurse on constants */
1993 return f->constants;
1997 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1999 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1);
2000 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
2002 (f1->flags.documentationp == f2->flags.documentationp &&
2003 f1->flags.interactivep == f2->flags.interactivep &&
2004 f1->flags.domainp == f2->flags.domainp && /* I18N3 */
2005 internal_equal (compiled_function_instructions (f1),
2006 compiled_function_instructions (f2), depth + 1) &&
2007 internal_equal (f1->constants, f2->constants, depth + 1) &&
2008 internal_equal (f1->arglist, f2->arglist, depth + 1) &&
2009 internal_equal (f1->doc_and_interactive,
2010 f2->doc_and_interactive, depth + 1));
2013 static unsigned long
2014 compiled_function_hash (Lisp_Object obj, int depth)
2016 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
2017 return HASH3 ((f->flags.documentationp << 2) +
2018 (f->flags.interactivep << 1) +
2020 internal_hash (f->instructions, depth + 1),
2021 internal_hash (f->constants, depth + 1));
2024 static const struct lrecord_description compiled_function_description[] = {
2025 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
2026 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
2027 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
2028 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
2029 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2030 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
2035 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
2036 mark_compiled_function,
2037 print_compiled_function, 0,
2038 compiled_function_equal,
2039 compiled_function_hash,
2040 compiled_function_description,
2041 Lisp_Compiled_Function);
2043 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
2044 Return t if OBJECT is a byte-compiled function object.
2048 return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
2051 /************************************************************************/
2052 /* compiled-function object accessor functions */
2053 /************************************************************************/
2056 compiled_function_arglist (Lisp_Compiled_Function *f)
2062 compiled_function_instructions (Lisp_Compiled_Function *f)
2064 if (! OPAQUEP (f->instructions))
2065 return f->instructions;
2068 /* Invert action performed by optimize_byte_code() */
2069 Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2071 Bufbyte * const buffer =
2072 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2073 Bufbyte *bp = buffer;
2075 const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
2076 const Opbyte *program_ptr = program;
2077 const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);
2079 while (program_ptr < program_end)
2081 Opcode opcode = (Opcode) READ_UINT_1;
2082 bp += set_charptr_emchar (bp, opcode);
2091 bp += set_charptr_emchar (bp, READ_UINT_1);
2092 bp += set_charptr_emchar (bp, READ_UINT_1);
2103 bp += set_charptr_emchar (bp, READ_UINT_1);
2109 case Bgotoifnilelsepop:
2110 case Bgotoifnonnilelsepop:
2112 int jump = READ_INT_2;
2114 Opbyte *buf2p = buf2;
2115 /* Convert back to program-relative address */
2116 WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
2117 bp += set_charptr_emchar (bp, buf2[0]);
2118 bp += set_charptr_emchar (bp, buf2[1]);
2124 case BRgotoifnonnil:
2125 case BRgotoifnilelsepop:
2126 case BRgotoifnonnilelsepop:
2127 bp += set_charptr_emchar (bp, READ_INT_1 + 127);
2134 return make_string (buffer, bp - buffer);
2139 compiled_function_constants (Lisp_Compiled_Function *f)
2141 return f->constants;
2145 compiled_function_stack_depth (Lisp_Compiled_Function *f)
2147 return f->stack_depth;
2150 /* The compiled_function->doc_and_interactive slot uses the minimal
2151 number of conses, based on compiled_function->flags; it may take
2152 any of the following forms:
2159 (interactive . domain)
2160 (doc . (interactive . domain))
2163 /* Caller must check flags.interactivep first */
2165 compiled_function_interactive (Lisp_Compiled_Function *f)
2167 assert (f->flags.interactivep);
2168 if (f->flags.documentationp && f->flags.domainp)
2169 return XCAR (XCDR (f->doc_and_interactive));
2170 else if (f->flags.documentationp)
2171 return XCDR (f->doc_and_interactive);
2172 else if (f->flags.domainp)
2173 return XCAR (f->doc_and_interactive);
2175 return f->doc_and_interactive;
2178 /* Caller need not check flags.documentationp first */
2180 compiled_function_documentation (Lisp_Compiled_Function *f)
2182 if (! f->flags.documentationp)
2184 else if (f->flags.interactivep && f->flags.domainp)
2185 return XCAR (f->doc_and_interactive);
2186 else if (f->flags.interactivep)
2187 return XCAR (f->doc_and_interactive);
2188 else if (f->flags.domainp)
2189 return XCAR (f->doc_and_interactive);
2191 return f->doc_and_interactive;
2194 /* Caller need not check flags.domainp first */
2196 compiled_function_domain (Lisp_Compiled_Function *f)
2198 if (! f->flags.domainp)
2200 else if (f->flags.documentationp && f->flags.interactivep)
2201 return XCDR (XCDR (f->doc_and_interactive));
2202 else if (f->flags.documentationp)
2203 return XCDR (f->doc_and_interactive);
2204 else if (f->flags.interactivep)
2205 return XCDR (f->doc_and_interactive);
2207 return f->doc_and_interactive;
2210 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2213 compiled_function_annotation (Lisp_Compiled_Function *f)
2215 return f->annotated;
2220 /* used only by Snarf-documentation; there must be doc already. */
2222 set_compiled_function_documentation (Lisp_Compiled_Function *f,
2223 Lisp_Object new_doc)
2225 assert (f->flags.documentationp);
2226 assert (INTP (new_doc) || STRINGP (new_doc));
2228 if (f->flags.interactivep && f->flags.domainp)
2229 XCAR (f->doc_and_interactive) = new_doc;
2230 else if (f->flags.interactivep)
2231 XCAR (f->doc_and_interactive) = new_doc;
2232 else if (f->flags.domainp)
2233 XCAR (f->doc_and_interactive) = new_doc;
2235 f->doc_and_interactive = new_doc;
2239 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2240 Return the argument list of the compiled-function object FUNCTION.
2244 CHECK_COMPILED_FUNCTION (function);
2245 return compiled_function_arglist (XCOMPILED_FUNCTION (function));
2248 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
2249 Return the byte-opcode string of the compiled-function object FUNCTION.
2253 CHECK_COMPILED_FUNCTION (function);
2254 return compiled_function_instructions (XCOMPILED_FUNCTION (function));
2257 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
2258 Return the constants vector of the compiled-function object FUNCTION.
2262 CHECK_COMPILED_FUNCTION (function);
2263 return compiled_function_constants (XCOMPILED_FUNCTION (function));
2266 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2267 Return the maximum stack depth of the compiled-function object FUNCTION.
2271 CHECK_COMPILED_FUNCTION (function);
2272 return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
2275 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
2276 Return the doc string of the compiled-function object FUNCTION, if available.
2277 Functions that had their doc strings snarfed into the DOC file will have
2278 an integer returned instead of a string.
2282 CHECK_COMPILED_FUNCTION (function);
2283 return compiled_function_documentation (XCOMPILED_FUNCTION (function));
2286 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2287 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2288 If non-nil, the return value will be a list whose first element is
2289 `interactive' and whose second element is the interactive spec.
2293 CHECK_COMPILED_FUNCTION (function);
2294 return XCOMPILED_FUNCTION (function)->flags.interactivep
2295 ? list2 (Qinteractive,
2296 compiled_function_interactive (XCOMPILED_FUNCTION (function)))
2300 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2302 /* Remove the `xx' if you wish to restore this feature */
2303 xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2304 Return the annotation of the compiled-function object FUNCTION, or nil.
2305 The annotation is a piece of information indicating where this
2306 compiled-function object came from. Generally this will be
2307 a symbol naming a function; or a string naming a file, if the
2308 compiled-function object was not defined in a function; or nil,
2309 if the compiled-function object was not created as a result of
2314 CHECK_COMPILED_FUNCTION (function);
2315 return compiled_function_annotation (XCOMPILED_FUNCTION (function));
2318 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2320 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
2321 Return the domain of the compiled-function object FUNCTION, or nil.
2322 This is only meaningful if I18N3 was enabled when emacs was compiled.
2326 CHECK_COMPILED_FUNCTION (function);
2327 return XCOMPILED_FUNCTION (function)->flags.domainp
2328 ? compiled_function_domain (XCOMPILED_FUNCTION (function))
2334 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
2335 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2339 Lisp_Compiled_Function *f;
2340 CHECK_COMPILED_FUNCTION (function);
2341 f = XCOMPILED_FUNCTION (function);
2343 if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
2346 if (CONSP (f->instructions))
2348 Lisp_Object tem = read_doc_string (f->instructions);
2350 signal_simple_error ("Invalid lazy-loaded byte code", tem);
2351 /* v18 or v19 bytecode file. Need to Ebolify. */
2352 if (f->flags.ebolified && VECTORP (XCDR (tem)))
2353 ebolify_bytecode_constants (XCDR (tem));
2354 f->instructions = XCAR (tem);
2355 f->constants = XCDR (tem);
2359 return Qnil; /* not reached */
2362 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
2363 Convert compiled function FUNCTION into an optimized internal form.
2367 Lisp_Compiled_Function *f;
2368 CHECK_COMPILED_FUNCTION (function);
2369 f = XCOMPILED_FUNCTION (function);
2371 if (OPAQUEP (f->instructions)) /* Already optimized? */
2374 optimize_compiled_function (function);
2378 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
2379 Function used internally in byte-compiled code.
2380 First argument INSTRUCTIONS is a string of byte code.
2381 Second argument CONSTANTS is a vector of constants.
2382 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2383 If STACK-DEPTH is incorrect, Emacs may crash.
2385 (instructions, constants, stack_depth))
2387 /* This function can GC */
2392 CHECK_STRING (instructions);
2393 CHECK_VECTOR (constants);
2394 CHECK_NATNUM (stack_depth);
2396 /* Optimize the `instructions' string, just like when executing a
2397 regular compiled function, but don't save it for later since this is
2398 likely to only be executed once. */
2399 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
2400 optimize_byte_code (instructions, constants, program,
2401 &program_length, &varbind_count);
2402 SPECPDL_RESERVE (varbind_count);
2403 return execute_optimized_program (program,
2405 XVECTOR_DATA (constants));
2410 syms_of_bytecode (void)
2412 INIT_LRECORD_IMPLEMENTATION (compiled_function);
2414 DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state);
2415 defsymbol (&Qbyte_code, "byte-code");
2416 defsymbol (&Qcompiled_functionp, "compiled-function-p");
2418 DEFSUBR (Fbyte_code);
2419 DEFSUBR (Ffetch_bytecode);
2420 DEFSUBR (Foptimize_compiled_function);
2422 DEFSUBR (Fcompiled_function_p);
2423 DEFSUBR (Fcompiled_function_instructions);
2424 DEFSUBR (Fcompiled_function_constants);
2425 DEFSUBR (Fcompiled_function_stack_depth);
2426 DEFSUBR (Fcompiled_function_arglist);
2427 DEFSUBR (Fcompiled_function_interactive);
2428 DEFSUBR (Fcompiled_function_doc_string);
2429 DEFSUBR (Fcompiled_function_domain);
2430 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2431 DEFSUBR (Fcompiled_function_annotation);
2434 #ifdef BYTE_CODE_METER
2435 defsymbol (&Qbyte_code_meter, "byte-code-meter");
2440 vars_of_bytecode (void)
2442 #ifdef BYTE_CODE_METER
2444 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
2445 A vector of vectors which holds a histogram of byte code usage.
2446 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2447 opcode CODE has been executed.
2448 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2449 indicates how many times the byte opcodes CODE1 and CODE2 have been
2450 executed in succession.
2452 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /*
2453 If non-nil, keep profiling information on byte code usage.
2454 The variable `byte-code-meter' indicates how often each byte opcode is used.
2455 If a symbol has a property named `byte-code-meter' whose value is an
2456 integer, it is incremented each time that symbol's function is called.
2459 byte_metering_on = 0;
2460 Vbyte_code_meter = make_vector (256, Qzero);
2464 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
2466 #endif /* BYTE_CODE_METER */