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 Lisp_Object symbol, tail;
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);
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);
509 goto wrong_number_of_arguments;
515 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions),
517 XVECTOR_DATA (f->constants));
519 /* The attempt to optimize this by only unbinding variables failed
520 because using buffer-local variables as function parameters
521 leads to specpdl_ptr->func != 0 */
522 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */
523 UNBIND_TO_GCPRO (speccount, value);
527 wrong_number_of_arguments:
528 /* The actual printed compiled_function object is incomprehensible.
529 Check the backtrace to see if we can get a more meaningful symbol. */
530 if (EQ (fun, indirect_function (*backtrace_list->function, 0)))
531 fun = *backtrace_list->function;
532 return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
536 /* Read next uint8 from the instruction stream. */
537 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
539 /* Read next uint16 from the instruction stream. */
540 #define READ_UINT_2 \
542 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \
543 ((unsigned int) (unsigned char) program_ptr[-2])))
545 /* Read next int8 from the instruction stream. */
546 #define READ_INT_1 ((int) (signed char) *program_ptr++)
548 /* Read next int16 from the instruction stream. */
551 (((int) ( signed char) program_ptr[-1]) * 256 + \
552 ((int) (unsigned char) program_ptr[-2])))
554 /* Read next int8 from instruction stream; don't advance program_pointer */
555 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
557 /* Read next int16 from instruction stream; don't advance program_pointer */
559 ((((int) ( signed char) program_ptr[1]) * 256) | \
560 ((int) (unsigned char) program_ptr[0]))
562 /* Do relative jumps from the current location.
563 We only do a QUIT if we jump backwards, for efficiency.
564 No infloops without backward jumps! */
565 #define JUMP_RELATIVE(jump) do { \
566 int JR_jump = (jump); \
567 if (JR_jump < 0) QUIT; \
568 program_ptr += JR_jump; \
571 #define JUMP JUMP_RELATIVE (PEEK_INT_2)
572 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
574 #define JUMP_NEXT ((void) (program_ptr += 2))
575 #define JUMPR_NEXT ((void) (program_ptr += 1))
577 /* Push x onto the execution stack. */
578 #define PUSH(x) (*++stack_ptr = (x))
580 /* Pop a value off the execution stack. */
581 #define POP (*stack_ptr--)
583 /* Discard n values from the execution stack. */
584 #define DISCARD(n) (stack_ptr -= (n))
586 /* Get the value which is at the top of the execution stack,
588 #define TOP (*stack_ptr)
590 /* The actual interpreter for byte code.
591 This function has been seriously optimized for performance.
592 Don't change the constructs unless you are willing to do
593 real benchmarking and profiling work -- martin */
597 execute_optimized_program (const Opbyte *program,
599 Lisp_Object *constants_data)
601 /* This function can GC */
602 REGISTER const Opbyte *program_ptr = (Opbyte *) program;
603 REGISTER Lisp_Object *stack_ptr
604 = alloca_array (Lisp_Object, stack_depth + 1);
605 int speccount = specpdl_depth ();
608 #ifdef BYTE_CODE_METER
609 Opcode this_opcode = 0;
613 #ifdef ERROR_CHECK_BYTE_CODE
614 Lisp_Object *stack_beg = stack_ptr;
615 Lisp_Object *stack_end = stack_beg + stack_depth;
618 /* Initialize all the objects on the stack to Qnil,
619 so we can GCPRO the whole stack.
620 The first element of the stack is actually a dummy. */
624 for (i = stack_depth, p = stack_ptr; i--;)
628 GCPRO1 (stack_ptr[1]);
629 gcpro1.nvars = stack_depth;
633 REGISTER Opcode opcode = (Opcode) READ_UINT_1;
634 #ifdef ERROR_CHECK_BYTE_CODE
635 if (stack_ptr > stack_end)
636 invalid_byte_code_error ("byte code stack overflow");
637 if (stack_ptr < stack_beg)
638 invalid_byte_code_error ("byte code stack underflow");
641 #ifdef BYTE_CODE_METER
642 prev_opcode = this_opcode;
643 this_opcode = opcode;
644 meter_code (prev_opcode, this_opcode);
652 if (opcode >= Bconstant)
653 PUSH (constants_data[opcode - Bconstant]);
655 stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode);
663 case Bvarref+5: n = opcode - Bvarref; goto do_varref;
664 case Bvarref+7: n = READ_UINT_2; goto do_varref;
665 case Bvarref+6: n = READ_UINT_1; /* most common */
668 Lisp_Object symbol = constants_data[n];
669 Lisp_Object value = XSYMBOL (symbol)->value;
670 if (SYMBOL_VALUE_MAGIC_P (value))
671 value = Fsymbol_value (symbol);
681 case Bvarset+5: n = opcode - Bvarset; goto do_varset;
682 case Bvarset+7: n = READ_UINT_2; goto do_varset;
683 case Bvarset+6: n = READ_UINT_1; /* most common */
686 Lisp_Object symbol = constants_data[n];
687 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
688 Lisp_Object old_value = symbol_ptr->value;
689 Lisp_Object new_value = POP;
690 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
691 symbol_ptr->value = new_value;
693 Fset (symbol, new_value);
702 case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind;
703 case Bvarbind+7: n = READ_UINT_2; goto do_varbind;
704 case Bvarbind+6: n = READ_UINT_1; /* most common */
707 Lisp_Object symbol = constants_data[n];
708 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
709 Lisp_Object old_value = symbol_ptr->value;
710 Lisp_Object new_value = POP;
711 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
713 specpdl_ptr->symbol = symbol;
714 specpdl_ptr->old_value = old_value;
715 specpdl_ptr->func = 0;
717 specpdl_depth_counter++;
719 symbol_ptr->value = new_value;
722 specbind_magic (symbol, new_value);
734 n = (opcode < Bcall+6 ? opcode - Bcall :
735 opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2);
737 #ifdef BYTE_CODE_METER
738 if (byte_metering_on && SYMBOLP (TOP))
740 Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
742 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
745 TOP = Ffuncall (n + 1, &TOP);
756 UNBIND_TO (specpdl_depth() -
757 (opcode < Bunbind+6 ? opcode-Bunbind :
758 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
780 case Bgotoifnilelsepop:
790 case Bgotoifnonnilelsepop:
819 case BRgotoifnilelsepop:
829 case BRgotoifnonnilelsepop:
841 #ifdef ERROR_CHECK_BYTE_CODE
842 /* Binds and unbinds are supposed to be compiled balanced. */
843 if (specpdl_depth() != speccount)
844 invalid_byte_code_error ("unbalanced specbinding stack");
854 Lisp_Object arg = TOP;
860 PUSH (constants_data[READ_UINT_2]);
864 TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
868 TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
873 /* To unbind back to the beginning of this frame. Not used yet,
874 but will be needed for tail-recursion elimination. */
875 unbind_to (speccount, Qnil);
880 Lisp_Object arg = POP;
881 TOP = Fcar (Fnthcdr (TOP, arg));
886 TOP = SYMBOLP (TOP) ? Qt : Qnil;
890 TOP = CONSP (TOP) ? Qt : Qnil;
894 TOP = STRINGP (TOP) ? Qt : Qnil;
898 TOP = LISTP (TOP) ? Qt : Qnil;
902 TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
906 TOP = INTP (TOP) ? Qt : Qnil;
911 Lisp_Object arg = POP;
912 TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
917 TOP = NILP (TOP) ? Qt : Qnil;
922 Lisp_Object arg = POP;
923 TOP = Fcons (TOP, arg);
928 TOP = Fcons (TOP, Qnil);
940 n = opcode - (Blist1 - 1);
943 Lisp_Object list = Qnil;
945 list = Fcons (TOP, list);
959 n = opcode - (Bconcat2 - 2);
967 TOP = Fconcat (n, &TOP);
977 Lisp_Object arg2 = POP;
978 Lisp_Object arg1 = POP;
979 TOP = Faset (TOP, arg1, arg2);
984 TOP = Fsymbol_value (TOP);
987 case Bsymbol_function:
988 TOP = Fsymbol_function (TOP);
993 Lisp_Object arg = POP;
994 TOP = Fget (TOP, arg, Qnil);
999 TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
1003 TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
1009 Lisp_Object arg = POP;
1010 TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
1016 Lisp_Object arg = POP;
1017 TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
1023 Lisp_Object arg = POP;
1024 TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
1030 Lisp_Object arg = POP;
1031 TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
1037 Lisp_Object arg = POP;
1038 TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
1044 TOP = bytecode_negate (TOP);
1049 TOP = bytecode_nconc2 (&TOP);
1054 Lisp_Object arg2 = POP;
1055 Lisp_Object arg1 = TOP;
1056 TOP = INTP (arg1) && INTP (arg2) ?
1057 INT_PLUS (arg1, arg2) :
1058 bytecode_arithop (arg1, arg2, opcode);
1064 Lisp_Object arg2 = POP;
1065 Lisp_Object arg1 = TOP;
1066 TOP = INTP (arg1) && INTP (arg2) ?
1067 INT_MINUS (arg1, arg2) :
1068 bytecode_arithop (arg1, arg2, opcode);
1077 Lisp_Object arg = POP;
1078 TOP = bytecode_arithop (TOP, arg, opcode);
1083 PUSH (make_int (BUF_PT (current_buffer)));
1087 TOP = Finsert (1, &TOP);
1093 TOP = Finsert (n, &TOP);
1098 Lisp_Object arg = POP;
1099 TOP = Faref (TOP, arg);
1105 Lisp_Object arg = POP;
1106 TOP = Fmemq (TOP, arg);
1112 Lisp_Object arg = POP;
1113 TOP = Fset (TOP, arg);
1119 Lisp_Object arg = POP;
1120 TOP = Fequal (TOP, arg);
1126 Lisp_Object arg = POP;
1127 TOP = Fnthcdr (TOP, arg);
1133 Lisp_Object arg = POP;
1134 TOP = Felt (TOP, arg);
1140 Lisp_Object arg = POP;
1141 TOP = Fmember (TOP, arg);
1146 TOP = Fgoto_char (TOP, Qnil);
1149 case Bcurrent_buffer:
1152 XSETBUFFER (buffer, current_buffer);
1158 TOP = Fset_buffer (TOP);
1162 PUSH (make_int (BUF_ZV (current_buffer)));
1166 PUSH (make_int (BUF_BEGV (current_buffer)));
1169 case Bskip_chars_forward:
1171 Lisp_Object arg = POP;
1172 TOP = Fskip_chars_forward (TOP, arg, Qnil);
1178 Lisp_Object arg = POP;
1179 TOP = Fassq (TOP, arg);
1185 Lisp_Object arg = POP;
1186 TOP = Fsetcar (TOP, arg);
1192 Lisp_Object arg = POP;
1193 TOP = Fsetcdr (TOP, arg);
1198 TOP = bytecode_nreverse (TOP);
1202 TOP = CONSP (TOP) ? XCAR (TOP) : Qnil;
1206 TOP = CONSP (TOP) ? XCDR (TOP) : Qnil;
1213 /* It makes a worthwhile performance difference (5%) to shunt
1214 lesser-used opcodes off to a subroutine, to keep the switch in
1215 execute_optimized_program small. If you REALLY care about
1216 performance, you want to keep your heavily executed code away from
1217 rarely executed code, to minimize cache misses.
1219 Don't make this function static, since then the compiler might inline it. */
1221 execute_rare_opcode (Lisp_Object *stack_ptr,
1222 const Opbyte *program_ptr,
1228 case Bsave_excursion:
1229 record_unwind_protect (save_excursion_restore,
1230 save_excursion_save ());
1233 case Bsave_window_excursion:
1235 int count = specpdl_depth ();
1236 record_unwind_protect (save_window_excursion_unwind,
1237 Fcurrent_window_configuration (Qnil));
1239 unbind_to (count, Qnil);
1243 case Bsave_restriction:
1244 record_unwind_protect (save_restriction_restore,
1245 save_restriction_save ());
1250 Lisp_Object arg = POP;
1251 TOP = internal_catch (TOP, Feval, arg, 0);
1255 case Bskip_chars_backward:
1257 Lisp_Object arg = POP;
1258 TOP = Fskip_chars_backward (TOP, arg, Qnil);
1262 case Bunwind_protect:
1263 record_unwind_protect (Fprogn, POP);
1266 case Bcondition_case:
1268 Lisp_Object arg2 = POP; /* handlers */
1269 Lisp_Object arg1 = POP; /* bodyform */
1270 TOP = condition_case_3 (arg1, TOP, arg2);
1276 Lisp_Object arg2 = POP;
1277 Lisp_Object arg1 = POP;
1278 TOP = Fset_marker (TOP, arg1, arg2);
1284 Lisp_Object arg = POP;
1285 TOP = Frem (TOP, arg);
1289 case Bmatch_beginning:
1290 TOP = Fmatch_beginning (TOP);
1294 TOP = Fmatch_end (TOP);
1298 TOP = Fupcase (TOP, Qnil);
1302 TOP = Fdowncase (TOP, Qnil);
1307 Lisp_Object arg = POP;
1308 TOP = Ffset (TOP, arg);
1314 Lisp_Object arg = POP;
1315 TOP = Fstring_equal (TOP, arg);
1321 Lisp_Object arg = POP;
1322 TOP = Fstring_lessp (TOP, arg);
1328 Lisp_Object arg2 = POP;
1329 Lisp_Object arg1 = POP;
1330 TOP = Fsubstring (TOP, arg1, arg2);
1334 case Bcurrent_column:
1335 PUSH (make_int (current_column (current_buffer)));
1339 TOP = Fchar_after (TOP, Qnil);
1343 TOP = Findent_to (TOP, Qnil, Qnil);
1347 PUSH (Fwiden (Qnil));
1350 case Bfollowing_char:
1351 PUSH (Ffollowing_char (Qnil));
1354 case Bpreceding_char:
1355 PUSH (Fpreceding_char (Qnil));
1359 PUSH (Feolp (Qnil));
1363 PUSH (Feobp (Qnil));
1367 PUSH (Fbolp (Qnil));
1371 PUSH (Fbobp (Qnil));
1374 case Bsave_current_buffer:
1375 record_unwind_protect (save_current_buffer_restore,
1376 Fcurrent_buffer ());
1379 case Binteractive_p:
1380 PUSH (Finteractive_p ());
1384 TOP = Fforward_char (TOP, Qnil);
1388 TOP = Fforward_word (TOP, Qnil);
1392 TOP = Fforward_line (TOP, Qnil);
1396 TOP = Fchar_syntax (TOP, Qnil);
1399 case Bbuffer_substring:
1401 Lisp_Object arg = POP;
1402 TOP = Fbuffer_substring (TOP, arg, Qnil);
1406 case Bdelete_region:
1408 Lisp_Object arg = POP;
1409 TOP = Fdelete_region (TOP, arg, Qnil);
1413 case Bnarrow_to_region:
1415 Lisp_Object arg = POP;
1416 TOP = Fnarrow_to_region (TOP, arg, Qnil);
1421 TOP = Fend_of_line (TOP, Qnil);
1424 case Btemp_output_buffer_setup:
1425 temp_output_buffer_setup (TOP);
1426 TOP = Vstandard_output;
1429 case Btemp_output_buffer_show:
1431 Lisp_Object arg = POP;
1432 temp_output_buffer_show (TOP, Qnil);
1435 /* pop binding of standard-output */
1436 unbind_to (specpdl_depth() - 1, Qnil);
1442 Lisp_Object arg = POP;
1443 TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
1449 Lisp_Object arg = POP;
1450 TOP = Fold_memq (TOP, arg);
1456 Lisp_Object arg = POP;
1457 TOP = Fold_equal (TOP, arg);
1463 Lisp_Object arg = POP;
1464 TOP = Fold_member (TOP, arg);
1470 Lisp_Object arg = POP;
1471 TOP = Fold_assq (TOP, arg);
1484 invalid_byte_code_error (char *error_message, ...)
1488 char *buf = alloca_array (char, strlen (error_message) + 128);
1490 sprintf (buf, "%s", error_message);
1491 va_start (args, error_message);
1492 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (buf), Qnil, -1,
1496 signal_error (Qinvalid_byte_code, list1 (obj));
1499 /* Check for valid opcodes. Change this when adding new opcodes. */
1501 check_opcode (Opcode opcode)
1503 if ((opcode < Bvarref) ||
1505 (opcode > Bassq && opcode < Bconstant))
1506 invalid_byte_code_error
1507 ("invalid opcode %d in instruction stream", opcode);
1510 /* Check that IDX is a valid offset into the `constants' vector */
1512 check_constants_index (int idx, Lisp_Object constants)
1514 if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
1515 invalid_byte_code_error
1516 ("reference %d to constants array out of range 0, %d",
1517 idx, XVECTOR_LENGTH (constants) - 1);
1520 /* Get next character from Lisp instructions string. */
1521 #define READ_INSTRUCTION_CHAR(lvalue) do { \
1522 (lvalue) = charptr_emchar (ptr); \
1523 INC_CHARPTR (ptr); \
1524 *icounts_ptr++ = program_ptr - program; \
1525 if (lvalue > UCHAR_MAX) \
1526 invalid_byte_code_error \
1527 ("Invalid character %c in byte code string"); \
1530 /* Get opcode from Lisp instructions string. */
1531 #define READ_OPCODE do { \
1533 READ_INSTRUCTION_CHAR (c); \
1534 opcode = (Opcode) c; \
1537 /* Get next operand, a uint8, from Lisp instructions string. */
1538 #define READ_OPERAND_1 do { \
1539 READ_INSTRUCTION_CHAR (arg); \
1543 /* Get next operand, a uint16, from Lisp instructions string. */
1544 #define READ_OPERAND_2 do { \
1545 unsigned int arg1, arg2; \
1546 READ_INSTRUCTION_CHAR (arg1); \
1547 READ_INSTRUCTION_CHAR (arg2); \
1548 arg = arg1 + (arg2 << 8); \
1552 /* Write 1 byte to PTR, incrementing PTR */
1553 #define WRITE_INT8(value, ptr) do { \
1554 *((ptr)++) = (value); \
1557 /* Write 2 bytes to PTR, incrementing PTR */
1558 #define WRITE_INT16(value, ptr) do { \
1559 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \
1560 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \
1563 /* We've changed our minds about the opcode we've already written. */
1564 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
1566 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
1567 #define WRITE_NARGS(base_opcode) do { \
1570 REWRITE_OPCODE (base_opcode + arg); \
1572 else if (arg <= UCHAR_MAX) \
1574 REWRITE_OPCODE (base_opcode + 6); \
1575 WRITE_INT8 (arg, program_ptr); \
1579 REWRITE_OPCODE (base_opcode + 7); \
1580 WRITE_INT16 (arg, program_ptr); \
1584 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
1585 #define WRITE_CONSTANT do { \
1586 check_constants_index(arg, constants); \
1587 if (arg <= UCHAR_MAX - Bconstant) \
1589 REWRITE_OPCODE (Bconstant + arg); \
1593 REWRITE_OPCODE (Bconstant2); \
1594 WRITE_INT16 (arg, program_ptr); \
1598 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
1600 /* Compile byte code instructions into free space provided by caller, with
1601 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
1602 Returns length of compiled code. */
1604 optimize_byte_code (/* in */
1605 Lisp_Object instructions,
1606 Lisp_Object constants,
1608 Opbyte * const program,
1609 int * const program_length,
1610 int * const varbind_count)
1612 size_t instructions_length = XSTRING_LENGTH (instructions);
1613 size_t comfy_size = 2 * instructions_length;
1615 int * const icounts = alloca_array (int, comfy_size);
1616 int * icounts_ptr = icounts;
1618 /* We maintain a table of jumps in the source code. */
1624 struct jump * const jumps = alloca_array (struct jump, comfy_size);
1625 struct jump *jumps_ptr = jumps;
1627 Opbyte *program_ptr = program;
1629 const Bufbyte *ptr = XSTRING_DATA (instructions);
1630 const Bufbyte * const end = ptr + instructions_length;
1646 case Bvarref+7: READ_OPERAND_2; goto do_varref;
1647 case Bvarref+6: READ_OPERAND_1; goto do_varref;
1648 case Bvarref: case Bvarref+1: case Bvarref+2:
1649 case Bvarref+3: case Bvarref+4: case Bvarref+5:
1650 arg = opcode - Bvarref;
1652 check_constants_index (arg, constants);
1653 val = XVECTOR_DATA (constants) [arg];
1655 invalid_byte_code_error ("variable reference to non-symbol %S", val);
1656 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1657 invalid_byte_code_error ("variable reference to constant symbol %s",
1658 string_data (XSYMBOL (val)->name));
1659 WRITE_NARGS (Bvarref);
1662 case Bvarset+7: READ_OPERAND_2; goto do_varset;
1663 case Bvarset+6: READ_OPERAND_1; goto do_varset;
1664 case Bvarset: case Bvarset+1: case Bvarset+2:
1665 case Bvarset+3: case Bvarset+4: case Bvarset+5:
1666 arg = opcode - Bvarset;
1668 check_constants_index (arg, constants);
1669 val = XVECTOR_DATA (constants) [arg];
1671 invalid_byte_code_error ("attempt to set non-symbol %S", val);
1672 if (EQ (val, Qnil) || EQ (val, Qt))
1673 invalid_byte_code_error ("attempt to set constant symbol %s",
1674 string_data (XSYMBOL (val)->name));
1675 /* Ignore assignments to keywords by converting to Bdiscard.
1676 For backward compatibility only - we'd like to make this an error. */
1677 if (SYMBOL_IS_KEYWORD (val))
1678 REWRITE_OPCODE (Bdiscard);
1680 WRITE_NARGS (Bvarset);
1683 case Bvarbind+7: READ_OPERAND_2; goto do_varbind;
1684 case Bvarbind+6: READ_OPERAND_1; goto do_varbind;
1685 case Bvarbind: case Bvarbind+1: case Bvarbind+2:
1686 case Bvarbind+3: case Bvarbind+4: case Bvarbind+5:
1687 arg = opcode - Bvarbind;
1690 check_constants_index (arg, constants);
1691 val = XVECTOR_DATA (constants) [arg];
1693 invalid_byte_code_error ("attempt to let-bind non-symbol %S", val);
1694 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1695 invalid_byte_code_error ("attempt to let-bind constant symbol %s",
1696 string_data (XSYMBOL (val)->name));
1697 WRITE_NARGS (Bvarbind);
1700 case Bcall+7: READ_OPERAND_2; goto do_call;
1701 case Bcall+6: READ_OPERAND_1; goto do_call;
1702 case Bcall: case Bcall+1: case Bcall+2:
1703 case Bcall+3: case Bcall+4: case Bcall+5:
1704 arg = opcode - Bcall;
1706 WRITE_NARGS (Bcall);
1709 case Bunbind+7: READ_OPERAND_2; goto do_unbind;
1710 case Bunbind+6: READ_OPERAND_1; goto do_unbind;
1711 case Bunbind: case Bunbind+1: case Bunbind+2:
1712 case Bunbind+3: case Bunbind+4: case Bunbind+5:
1713 arg = opcode - Bunbind;
1715 WRITE_NARGS (Bunbind);
1721 case Bgotoifnilelsepop:
1722 case Bgotoifnonnilelsepop:
1724 /* Make program_ptr-relative */
1725 arg += icounts - (icounts_ptr - argsize);
1730 case BRgotoifnonnil:
1731 case BRgotoifnilelsepop:
1732 case BRgotoifnonnilelsepop:
1734 /* Make program_ptr-relative */
1737 /* Record program-relative goto addresses in `jumps' table */
1738 jumps_ptr->from = icounts_ptr - icounts - argsize;
1739 jumps_ptr->to = jumps_ptr->from + arg;
1741 if (arg >= -1 && arg <= argsize)
1742 invalid_byte_code_error
1743 ("goto instruction is its own target");
1744 if (arg <= SCHAR_MIN ||
1748 REWRITE_OPCODE (opcode + Bgoto - BRgoto);
1749 WRITE_INT16 (arg, program_ptr);
1754 REWRITE_OPCODE (opcode + BRgoto - Bgoto);
1755 WRITE_INT8 (arg, program_ptr);
1768 WRITE_INT8 (arg, program_ptr);
1772 if (opcode < Bconstant)
1773 check_opcode (opcode);
1776 arg = opcode - Bconstant;
1783 /* Fix up jumps table to refer to NEW offsets. */
1786 for (j = jumps; j < jumps_ptr; j++)
1788 #ifdef ERROR_CHECK_BYTE_CODE
1789 assert (j->from < icounts_ptr - icounts);
1790 assert (j->to < icounts_ptr - icounts);
1792 j->from = icounts[j->from];
1793 j->to = icounts[j->to];
1794 #ifdef ERROR_CHECK_BYTE_CODE
1795 assert (j->from < program_ptr - program);
1796 assert (j->to < program_ptr - program);
1797 check_opcode ((Opcode) (program[j->from-1]));
1799 check_opcode ((Opcode) (program[j->to]));
1803 /* Fixup jumps in byte-code until no more fixups needed */
1805 int more_fixups_needed = 1;
1807 while (more_fixups_needed)
1810 more_fixups_needed = 0;
1811 for (j = jumps; j < jumps_ptr; j++)
1815 int jump = to - from;
1816 Opbyte *p = program + from;
1817 Opcode opcode = (Opcode) p[-1];
1818 if (!more_fixups_needed)
1819 check_opcode ((Opcode) p[jump]);
1820 assert (to >= 0 && program + to < program_ptr);
1826 case Bgotoifnilelsepop:
1827 case Bgotoifnonnilelsepop:
1828 WRITE_INT16 (jump, p);
1833 case BRgotoifnonnil:
1834 case BRgotoifnilelsepop:
1835 case BRgotoifnonnilelsepop:
1836 if (jump > SCHAR_MIN &&
1839 WRITE_INT8 (jump, p);
1844 for (jj = jumps; jj < jumps_ptr; jj++)
1846 assert (jj->from < program_ptr - program);
1847 assert (jj->to < program_ptr - program);
1848 if (jj->from > from) jj->from++;
1849 if (jj->to > from) jj->to++;
1851 p[-1] += Bgoto - BRgoto;
1852 more_fixups_needed = 1;
1853 memmove (p+1, p, program_ptr++ - p);
1854 WRITE_INT16 (jump, p);
1866 /* *program_ptr++ = 0; */
1867 *program_length = program_ptr - program;
1870 /* Optimize the byte code and store the optimized program, only
1871 understood by bytecode.c, in an opaque object in the
1872 instructions slot of the Compiled_Function object. */
1874 optimize_compiled_function (Lisp_Object compiled_function)
1876 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
1881 /* If we have not actually read the bytecode string
1882 and constants vector yet, fetch them from the file. */
1883 if (CONSP (f->instructions))
1884 Ffetch_bytecode (compiled_function);
1886 if (STRINGP (f->instructions))
1888 /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1889 which would be slightly more `proper' */
1890 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
1891 optimize_byte_code (f->instructions, f->constants,
1892 program, &program_length, &varbind_count);
1893 f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
1895 make_opaque (program, program_length * sizeof (Opbyte));
1898 assert (OPAQUEP (f->instructions));
1901 /************************************************************************/
1902 /* The compiled-function object type */
1903 /************************************************************************/
1905 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
1908 /* This function can GC */
1909 Lisp_Compiled_Function *f =
1910 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
1911 int docp = f->flags.documentationp;
1912 int intp = f->flags.interactivep;
1913 struct gcpro gcpro1, gcpro2;
1915 GCPRO2 (obj, printcharfun);
1917 write_c_string (print_readably ? "#[" : "#<compiled-function ", printcharfun);
1918 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1919 if (!print_readably)
1921 Lisp_Object ann = compiled_function_annotation (f);
1924 write_c_string ("(from ", printcharfun);
1925 print_internal (ann, printcharfun, 1);
1926 write_c_string (") ", printcharfun);
1929 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1930 /* COMPILED_ARGLIST = 0 */
1931 print_internal (compiled_function_arglist (f), printcharfun, escapeflag);
1933 /* COMPILED_INSTRUCTIONS = 1 */
1934 write_c_string (" ", printcharfun);
1936 struct gcpro ngcpro1;
1937 Lisp_Object instructions = compiled_function_instructions (f);
1938 NGCPRO1 (instructions);
1939 if (STRINGP (instructions) && !print_readably)
1941 /* We don't usually want to see that junk in the bytecode. */
1942 sprintf (buf, "\"...(%ld)\"",
1943 (long) XSTRING_CHAR_LENGTH (instructions));
1944 write_c_string (buf, printcharfun);
1947 print_internal (instructions, printcharfun, escapeflag);
1951 /* COMPILED_CONSTANTS = 2 */
1952 write_c_string (" ", printcharfun);
1953 print_internal (compiled_function_constants (f), printcharfun, escapeflag);
1955 /* COMPILED_STACK_DEPTH = 3 */
1956 sprintf (buf, " %d", compiled_function_stack_depth (f));
1957 write_c_string (buf, printcharfun);
1959 /* COMPILED_DOC_STRING = 4 */
1962 write_c_string (" ", printcharfun);
1963 print_internal (compiled_function_documentation (f), printcharfun,
1967 /* COMPILED_INTERACTIVE = 5 */
1970 write_c_string (" ", printcharfun);
1971 print_internal (compiled_function_interactive (f), printcharfun,
1976 write_c_string (print_readably ? "]" : ">", printcharfun);
1981 mark_compiled_function (Lisp_Object obj)
1983 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1985 mark_object (f->instructions);
1986 mark_object (f->arglist);
1987 mark_object (f->doc_and_interactive);
1988 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1989 mark_object (f->annotated);
1991 /* tail-recurse on constants */
1992 return f->constants;
1996 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1998 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1);
1999 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
2001 (f1->flags.documentationp == f2->flags.documentationp &&
2002 f1->flags.interactivep == f2->flags.interactivep &&
2003 f1->flags.domainp == f2->flags.domainp && /* I18N3 */
2004 internal_equal (compiled_function_instructions (f1),
2005 compiled_function_instructions (f2), depth + 1) &&
2006 internal_equal (f1->constants, f2->constants, depth + 1) &&
2007 internal_equal (f1->arglist, f2->arglist, depth + 1) &&
2008 internal_equal (f1->doc_and_interactive,
2009 f2->doc_and_interactive, depth + 1));
2012 static unsigned long
2013 compiled_function_hash (Lisp_Object obj, int depth)
2015 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
2016 return HASH3 ((f->flags.documentationp << 2) +
2017 (f->flags.interactivep << 1) +
2019 internal_hash (f->instructions, depth + 1),
2020 internal_hash (f->constants, depth + 1));
2023 static const struct lrecord_description compiled_function_description[] = {
2024 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
2025 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
2026 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
2027 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
2028 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2029 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
2034 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
2035 mark_compiled_function,
2036 print_compiled_function, 0,
2037 compiled_function_equal,
2038 compiled_function_hash,
2039 compiled_function_description,
2040 Lisp_Compiled_Function);
2042 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
2043 Return t if OBJECT is a byte-compiled function object.
2047 return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
2050 /************************************************************************/
2051 /* compiled-function object accessor functions */
2052 /************************************************************************/
2055 compiled_function_arglist (Lisp_Compiled_Function *f)
2061 compiled_function_instructions (Lisp_Compiled_Function *f)
2063 if (! OPAQUEP (f->instructions))
2064 return f->instructions;
2067 /* Invert action performed by optimize_byte_code() */
2068 Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2070 Bufbyte * const buffer =
2071 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2072 Bufbyte *bp = buffer;
2074 const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
2075 const Opbyte *program_ptr = program;
2076 const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);
2078 while (program_ptr < program_end)
2080 Opcode opcode = (Opcode) READ_UINT_1;
2081 bp += set_charptr_emchar (bp, opcode);
2090 bp += set_charptr_emchar (bp, READ_UINT_1);
2091 bp += set_charptr_emchar (bp, READ_UINT_1);
2102 bp += set_charptr_emchar (bp, READ_UINT_1);
2108 case Bgotoifnilelsepop:
2109 case Bgotoifnonnilelsepop:
2111 int jump = READ_INT_2;
2113 Opbyte *buf2p = buf2;
2114 /* Convert back to program-relative address */
2115 WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
2116 bp += set_charptr_emchar (bp, buf2[0]);
2117 bp += set_charptr_emchar (bp, buf2[1]);
2123 case BRgotoifnonnil:
2124 case BRgotoifnilelsepop:
2125 case BRgotoifnonnilelsepop:
2126 bp += set_charptr_emchar (bp, READ_INT_1 + 127);
2133 return make_string (buffer, bp - buffer);
2138 compiled_function_constants (Lisp_Compiled_Function *f)
2140 return f->constants;
2144 compiled_function_stack_depth (Lisp_Compiled_Function *f)
2146 return f->stack_depth;
2149 /* The compiled_function->doc_and_interactive slot uses the minimal
2150 number of conses, based on compiled_function->flags; it may take
2151 any of the following forms:
2158 (interactive . domain)
2159 (doc . (interactive . domain))
2162 /* Caller must check flags.interactivep first */
2164 compiled_function_interactive (Lisp_Compiled_Function *f)
2166 assert (f->flags.interactivep);
2167 if (f->flags.documentationp && f->flags.domainp)
2168 return XCAR (XCDR (f->doc_and_interactive));
2169 else if (f->flags.documentationp)
2170 return XCDR (f->doc_and_interactive);
2171 else if (f->flags.domainp)
2172 return XCAR (f->doc_and_interactive);
2174 return f->doc_and_interactive;
2177 /* Caller need not check flags.documentationp first */
2179 compiled_function_documentation (Lisp_Compiled_Function *f)
2181 if (! f->flags.documentationp)
2183 else if (f->flags.interactivep && f->flags.domainp)
2184 return XCAR (f->doc_and_interactive);
2185 else if (f->flags.interactivep)
2186 return XCAR (f->doc_and_interactive);
2187 else if (f->flags.domainp)
2188 return XCAR (f->doc_and_interactive);
2190 return f->doc_and_interactive;
2193 /* Caller need not check flags.domainp first */
2195 compiled_function_domain (Lisp_Compiled_Function *f)
2197 if (! f->flags.domainp)
2199 else if (f->flags.documentationp && f->flags.interactivep)
2200 return XCDR (XCDR (f->doc_and_interactive));
2201 else if (f->flags.documentationp)
2202 return XCDR (f->doc_and_interactive);
2203 else if (f->flags.interactivep)
2204 return XCDR (f->doc_and_interactive);
2206 return f->doc_and_interactive;
2209 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2212 compiled_function_annotation (Lisp_Compiled_Function *f)
2214 return f->annotated;
2219 /* used only by Snarf-documentation; there must be doc already. */
2221 set_compiled_function_documentation (Lisp_Compiled_Function *f,
2222 Lisp_Object new_doc)
2224 assert (f->flags.documentationp);
2225 assert (INTP (new_doc) || STRINGP (new_doc));
2227 if (f->flags.interactivep && f->flags.domainp)
2228 XCAR (f->doc_and_interactive) = new_doc;
2229 else if (f->flags.interactivep)
2230 XCAR (f->doc_and_interactive) = new_doc;
2231 else if (f->flags.domainp)
2232 XCAR (f->doc_and_interactive) = new_doc;
2234 f->doc_and_interactive = new_doc;
2238 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2239 Return the argument list of the compiled-function object FUNCTION.
2243 CHECK_COMPILED_FUNCTION (function);
2244 return compiled_function_arglist (XCOMPILED_FUNCTION (function));
2247 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
2248 Return the byte-opcode string of the compiled-function object FUNCTION.
2252 CHECK_COMPILED_FUNCTION (function);
2253 return compiled_function_instructions (XCOMPILED_FUNCTION (function));
2256 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
2257 Return the constants vector of the compiled-function object FUNCTION.
2261 CHECK_COMPILED_FUNCTION (function);
2262 return compiled_function_constants (XCOMPILED_FUNCTION (function));
2265 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2266 Return the max stack depth of the compiled-function object FUNCTION.
2270 CHECK_COMPILED_FUNCTION (function);
2271 return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
2274 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
2275 Return the doc string of the compiled-function object FUNCTION, if available.
2276 Functions that had their doc strings snarfed into the DOC file will have
2277 an integer returned instead of a string.
2281 CHECK_COMPILED_FUNCTION (function);
2282 return compiled_function_documentation (XCOMPILED_FUNCTION (function));
2285 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2286 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2287 If non-nil, the return value will be a list whose first element is
2288 `interactive' and whose second element is the interactive spec.
2292 CHECK_COMPILED_FUNCTION (function);
2293 return XCOMPILED_FUNCTION (function)->flags.interactivep
2294 ? list2 (Qinteractive,
2295 compiled_function_interactive (XCOMPILED_FUNCTION (function)))
2299 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2301 /* Remove the `xx' if you wish to restore this feature */
2302 xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2303 Return the annotation of the compiled-function object FUNCTION, or nil.
2304 The annotation is a piece of information indicating where this
2305 compiled-function object came from. Generally this will be
2306 a symbol naming a function; or a string naming a file, if the
2307 compiled-function object was not defined in a function; or nil,
2308 if the compiled-function object was not created as a result of
2313 CHECK_COMPILED_FUNCTION (function);
2314 return compiled_function_annotation (XCOMPILED_FUNCTION (function));
2317 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2319 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
2320 Return the domain of the compiled-function object FUNCTION, or nil.
2321 This is only meaningful if I18N3 was enabled when emacs was compiled.
2325 CHECK_COMPILED_FUNCTION (function);
2326 return XCOMPILED_FUNCTION (function)->flags.domainp
2327 ? compiled_function_domain (XCOMPILED_FUNCTION (function))
2333 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
2334 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2338 Lisp_Compiled_Function *f;
2339 CHECK_COMPILED_FUNCTION (function);
2340 f = XCOMPILED_FUNCTION (function);
2342 if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
2345 if (CONSP (f->instructions))
2347 Lisp_Object tem = read_doc_string (f->instructions);
2349 signal_simple_error ("Invalid lazy-loaded byte code", tem);
2350 /* v18 or v19 bytecode file. Need to Ebolify. */
2351 if (f->flags.ebolified && VECTORP (XCDR (tem)))
2352 ebolify_bytecode_constants (XCDR (tem));
2353 f->instructions = XCAR (tem);
2354 f->constants = XCDR (tem);
2358 return Qnil; /* not reached */
2361 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
2362 Convert compiled function FUNCTION into an optimized internal form.
2366 Lisp_Compiled_Function *f;
2367 CHECK_COMPILED_FUNCTION (function);
2368 f = XCOMPILED_FUNCTION (function);
2370 if (OPAQUEP (f->instructions)) /* Already optimized? */
2373 optimize_compiled_function (function);
2377 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
2378 Function used internally in byte-compiled code.
2379 First argument INSTRUCTIONS is a string of byte code.
2380 Second argument CONSTANTS is a vector of constants.
2381 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2382 If STACK-DEPTH is incorrect, Emacs may crash.
2384 (instructions, constants, stack_depth))
2386 /* This function can GC */
2391 CHECK_STRING (instructions);
2392 CHECK_VECTOR (constants);
2393 CHECK_NATNUM (stack_depth);
2395 /* Optimize the `instructions' string, just like when executing a
2396 regular compiled function, but don't save it for later since this is
2397 likely to only be executed once. */
2398 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
2399 optimize_byte_code (instructions, constants, program,
2400 &program_length, &varbind_count);
2401 SPECPDL_RESERVE (varbind_count);
2402 return execute_optimized_program (program,
2404 XVECTOR_DATA (constants));
2409 syms_of_bytecode (void)
2411 INIT_LRECORD_IMPLEMENTATION (compiled_function);
2413 deferror (&Qinvalid_byte_code, "invalid-byte-code",
2414 "Invalid byte code", Qerror);
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 */