1 /* Execution of byte code produced by bytecomp.el.
2 Implementation of compiled-function objects.
3 Copyright (C) 1992, 1993 Free Software Foundation, Inc.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Mule 2.0, FSF 19.30. */
24 /* This file has been Mule-ized. */
31 hacked on by jwz@netscape.com 1991-06
32 o added a compile-time switch to turn on simple sanity checking;
33 o put back the obsolete byte-codes for error-detection;
34 o added a new instruction, unbind_all, which I will use for
35 tail-recursion elimination;
36 o made temp_output_buffer_show be called with the right number
38 o made the new bytecodes be called with args in the right order;
39 o added metering support.
42 o added relative jump instructions;
43 o all conditionals now only do QUIT if they jump.
45 Ben Wing: some changes for Mule, 1995-06.
47 Martin Buchholz: performance hacking, 1998-09.
48 See Internals Manual, Evaluation.
53 #include "backtrace.h"
62 EXFUN (Ffetch_bytecode, 1);
64 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
66 enum Opcode /* Byte codes */
93 Bsymbol_function = 0113,
116 Beq = 0141, /* was Bmark,
117 but no longer generated as of v18 */
123 Bfollowing_char = 0147,
124 Bpreceding_char = 0150,
125 Bcurrent_column = 0151,
127 Bequal = 0153, /* was Bscan_buffer,
128 but no longer generated as of v18 */
133 Bcurrent_buffer = 0160,
135 Bsave_current_buffer = 0162, /* was Bread_char,
136 but no longer generated as of v19 */
137 Bmemq = 0163, /* was Bset_mark,
138 but no longer generated as of v18 */
139 Binteractive_p = 0164, /* Needed since interactive-p takes
141 Bforward_char = 0165,
142 Bforward_word = 0166,
143 Bskip_chars_forward = 0167,
144 Bskip_chars_backward = 0170,
145 Bforward_line = 0171,
147 Bbuffer_substring = 0173,
148 Bdelete_region = 0174,
149 Bnarrow_to_region = 0175,
156 Bgotoifnonnil = 0204,
157 Bgotoifnilelsepop = 0205,
158 Bgotoifnonnilelsepop = 0206,
163 Bsave_excursion = 0212,
164 Bsave_window_excursion= 0213,
165 Bsave_restriction = 0214,
168 Bunwind_protect = 0216,
169 Bcondition_case = 0217,
170 Btemp_output_buffer_setup = 0220,
171 Btemp_output_buffer_show = 0221,
176 Bmatch_beginning = 0224,
181 Bstring_equal = 0230,
182 Bstring_lessp = 0231,
201 BRgotoifnonnil = 0254,
202 BRgotoifnilelsepop = 0255,
203 BRgotoifnonnilelsepop = 0256,
208 Bmember = 0266, /* new in v20 */
209 Bassq = 0267, /* new in v20 */
213 typedef enum Opcode Opcode;
214 typedef unsigned char Opbyte;
217 static void invalid_byte_code_error (char *error_message, ...);
219 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
220 CONST Opbyte *program_ptr,
223 static Lisp_Object execute_optimized_program (CONST Opbyte *program,
225 Lisp_Object *constants_data);
227 extern Lisp_Object Qand_rest, Qand_optional;
229 /* Define ERROR_CHECK_BYTE_CODE to enable some minor sanity checking.
230 Useful for debugging the byte compiler. */
232 #define ERROR_CHECK_BYTE_CODE
235 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
236 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
237 /* #define BYTE_CODE_METER */
240 #ifdef BYTE_CODE_METER
242 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
243 int byte_metering_on;
245 #define METER_2(code1, code2) \
246 XINT (XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[(code1)])[(code2)])
248 #define METER_1(code) METER_2 (0, (code))
250 #define METER_CODE(last_code, this_code) do { \
251 if (byte_metering_on) \
253 if (METER_1 (this_code) != ((1<<VALBITS)-1)) \
254 METER_1 (this_code)++; \
256 && METER_2 (last_code, this_code) != ((1<<VALBITS)-1)) \
257 METER_2 (last_code, this_code)++; \
261 #endif /* BYTE_CODE_METER */
265 bytecode_negate (Lisp_Object obj)
269 #ifdef LISP_FLOAT_TYPE
270 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
272 if (CHARP (obj)) return make_int (- ((int) XCHAR (obj)));
273 if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));
274 if (INTP (obj)) return make_int (- XINT (obj));
276 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
281 bytecode_nreverse (Lisp_Object list)
283 REGISTER Lisp_Object prev = Qnil;
284 REGISTER Lisp_Object tail = list;
288 REGISTER Lisp_Object next;
299 /* We have our own two-argument versions of various arithmetic ops.
300 Only two-argument arithmetic operations have their own byte codes. */
302 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2)
306 #ifdef LISP_FLOAT_TYPE
310 if (INTP (obj1)) ival1 = XINT (obj1);
311 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
312 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
313 else goto arithcompare_float;
315 if (INTP (obj2)) ival2 = XINT (obj2);
316 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
317 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
318 else goto arithcompare_float;
320 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
328 if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1);
329 else if (INTP (obj1)) dval1 = (double) XINT (obj1);
330 else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1);
331 else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1);
334 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
338 if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2);
339 else if (INTP (obj2)) dval2 = (double) XINT (obj2);
340 else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2);
341 else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2);
344 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
348 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
350 #else /* !LISP_FLOAT_TYPE */
354 if (INTP (obj1)) ival1 = XINT (obj1);
355 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
356 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
359 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
363 if (INTP (obj2)) ival2 = XINT (obj2);
364 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
365 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
368 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
372 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
374 #endif /* !LISP_FLOAT_TYPE */
378 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
380 #ifdef LISP_FLOAT_TYPE
388 if (INTP (obj1)) ival1 = XINT (obj1);
389 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
390 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
391 else if (FLOATP (obj1)) ival1 = 0, float_p = 1;
394 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
398 if (INTP (obj2)) ival2 = XINT (obj2);
399 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
400 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
401 else if (FLOATP (obj2)) ival2 = 0, float_p = 1;
404 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
412 case Bplus: ival1 += ival2; break;
413 case Bdiff: ival1 -= ival2; break;
414 case Bmult: ival1 *= ival2; break;
416 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
419 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
420 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
422 return make_int (ival1);
426 double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1;
427 double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2;
430 case Bplus: dval1 += dval2; break;
431 case Bdiff: dval1 -= dval2; break;
432 case Bmult: dval1 *= dval2; break;
434 if (dval2 == 0) Fsignal (Qarith_error, Qnil);
437 case Bmax: if (dval1 < dval2) dval1 = dval2; break;
438 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
440 return make_float (dval1);
442 #else /* !LISP_FLOAT_TYPE */
447 if (INTP (obj1)) ival1 = XINT (obj1);
448 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
449 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
452 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
456 if (INTP (obj2)) ival2 = XINT (obj2);
457 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
458 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
461 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
467 case Bplus: ival1 += ival2; break;
468 case Bdiff: ival1 -= ival2; break;
469 case Bmult: ival1 *= ival2; break;
471 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
474 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
475 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
477 return make_int (ival1);
478 #endif /* !LISP_FLOAT_TYPE */
481 /* Apply compiled-function object FUN to the NARGS evaluated arguments
482 in ARGS, and return the result of evaluation. */
484 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[])
486 /* This function can GC */
487 Lisp_Object symbol, tail;
488 int speccount = specpdl_depth();
490 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
493 if (!OPAQUEP (f->instructions))
494 /* Lazily munge the instructions into a more efficient form */
495 optimize_compiled_function (fun);
497 /* optimize_compiled_function() guaranteed that f->specpdl_depth is
498 the required space on the specbinding stack for binding the args
499 and local variables of fun. So just reserve it once. */
500 SPECPDL_RESERVE (f->specpdl_depth);
502 /* Fmake_byte_code() guaranteed that f->arglist is a valid list
503 containing only non-constant symbols. */
504 LIST_LOOP_3 (symbol, f->arglist, tail)
506 if (EQ (symbol, Qand_rest))
509 symbol = XCAR (tail);
510 SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i]));
513 else if (EQ (symbol, Qand_optional))
515 else if (i == nargs && !optional)
516 goto wrong_number_of_arguments;
518 SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil);
522 goto wrong_number_of_arguments;
528 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions),
530 XVECTOR_DATA (f->constants));
532 UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value);
536 wrong_number_of_arguments:
537 return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
541 /* Read next uint8 from the instruction stream. */
542 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
544 /* Read next uint16 from the instruction stream. */
545 #define READ_UINT_2 \
547 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \
548 ((unsigned int) (unsigned char) program_ptr[-2])))
550 /* Read next int8 from the instruction stream. */
551 #define READ_INT_1 ((int) (signed char) *program_ptr++)
553 /* Read next int16 from the instruction stream. */
556 (((int) ( signed char) program_ptr[-1]) * 256 + \
557 ((int) (unsigned char) program_ptr[-2])))
559 /* Read next int8 from instruction stream; don't advance program_pointer */
560 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
562 /* Read next int16 from instruction stream; don't advance program_pointer */
564 ((((int) ( signed char) program_ptr[1]) * 256) | \
565 ((int) (unsigned char) program_ptr[0]))
567 /* Do relative jumps from the current location.
568 We only do a QUIT if we jump backwards, for efficiency.
569 No infloops without backward jumps! */
570 #define JUMP_RELATIVE(jump) do { \
571 int JR_jump = (jump); \
572 if (JR_jump < 0) QUIT; \
573 program_ptr += JR_jump; \
576 #define JUMP JUMP_RELATIVE (PEEK_INT_2)
577 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
579 #define JUMP_NEXT ((void) (program_ptr += 2))
580 #define JUMPR_NEXT ((void) (program_ptr += 1))
582 /* Push x onto the execution stack. */
583 #define PUSH(x) (*++stack_ptr = (x))
585 /* Pop a value off the execution stack. */
586 #define POP (*stack_ptr--)
588 /* Discard n values from the execution stack. */
589 #define DISCARD(n) (stack_ptr -= (n))
591 /* Get the value which is at the top of the execution stack,
593 #define TOP (*stack_ptr)
595 /* The actual interpreter for byte code.
596 This function has been seriously optimized for performance.
597 Don't change the constructs unless you are willing to do
598 real benchmarking and profiling work -- martin */
602 execute_optimized_program (CONST Opbyte *program,
604 Lisp_Object *constants_data)
606 /* This function can GC */
607 REGISTER CONST Opbyte *program_ptr = (Opbyte *) program;
608 REGISTER Lisp_Object *stack_ptr
609 = alloca_array (Lisp_Object, stack_depth + 1);
610 int speccount = specpdl_depth ();
613 #ifdef BYTE_CODE_METER
614 Opcode this_opcode = 0;
618 #ifdef ERROR_CHECK_BYTE_CODE
619 Lisp_Object *stack_beg = stack_ptr;
620 Lisp_Object *stack_end = stack_beg + stack_depth;
623 /* Initialize all the objects on the stack to Qnil,
624 so we can GCPRO the whole stack.
625 The first element of the stack is actually a dummy. */
629 for (i = stack_depth, p = stack_ptr; i--;)
633 GCPRO1 (stack_ptr[1]);
634 gcpro1.nvars = stack_depth;
638 REGISTER Opcode opcode = (Opcode) READ_UINT_1;
639 #ifdef ERROR_CHECK_BYTE_CODE
640 if (stack_ptr > stack_end)
641 invalid_byte_code_error ("byte code stack overflow");
642 if (stack_ptr < stack_beg)
643 invalid_byte_code_error ("byte code stack underflow");
646 #ifdef BYTE_CODE_METER
647 prev_opcode = this_opcode;
648 this_opcode = opcode;
649 METER_CODE (prev_opcode, this_opcode);
657 if (opcode >= Bconstant)
658 PUSH (constants_data[opcode - Bconstant]);
660 stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode);
668 case Bvarref+5: n = opcode - Bvarref; goto do_varref;
669 case Bvarref+7: n = READ_UINT_2; goto do_varref;
670 case Bvarref+6: n = READ_UINT_1; /* most common */
673 Lisp_Object symbol = constants_data[n];
674 Lisp_Object value = XSYMBOL (symbol)->value;
675 if (SYMBOL_VALUE_MAGIC_P (value))
676 value = Fsymbol_value (symbol);
686 case Bvarset+5: n = opcode - Bvarset; goto do_varset;
687 case Bvarset+7: n = READ_UINT_2; goto do_varset;
688 case Bvarset+6: n = READ_UINT_1; /* most common */
691 Lisp_Object symbol = constants_data[n];
692 struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
693 Lisp_Object old_value = symbol_ptr->value;
694 Lisp_Object new_value = POP;
695 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
696 symbol_ptr->value = new_value;
698 Fset (symbol, new_value);
707 case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind;
708 case Bvarbind+7: n = READ_UINT_2; goto do_varbind;
709 case Bvarbind+6: n = READ_UINT_1; /* most common */
712 Lisp_Object symbol = constants_data[n];
713 struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
714 Lisp_Object old_value = symbol_ptr->value;
715 Lisp_Object new_value = POP;
716 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
718 specpdl_ptr->symbol = symbol;
719 specpdl_ptr->old_value = old_value;
720 specpdl_ptr->func = 0;
722 specpdl_depth_counter++;
724 symbol_ptr->value = new_value;
727 specbind_magic (symbol, new_value);
739 n = (opcode < Bcall+6 ? opcode - Bcall :
740 opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2);
742 #ifdef BYTE_CODE_METER
743 if (byte_metering_on && SYMBOLP (TOP))
745 Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
747 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
750 TOP = Ffuncall (n + 1, &TOP);
761 UNBIND_TO (specpdl_depth() -
762 (opcode < Bunbind+6 ? opcode-Bunbind :
763 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
784 case Bgotoifnilelsepop:
794 case Bgotoifnonnilelsepop:
823 case BRgotoifnilelsepop:
833 case BRgotoifnonnilelsepop:
845 #ifdef ERROR_CHECK_BYTE_CODE
846 /* Binds and unbinds are supposed to be compiled balanced. */
847 if (specpdl_depth() != speccount)
848 invalid_byte_code_error ("unbalanced specbinding stack");
858 Lisp_Object arg = TOP;
864 PUSH (constants_data[READ_UINT_2]);
868 TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
872 TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
877 /* To unbind back to the beginning of this frame. Not used yet,
878 but will be needed for tail-recursion elimination. */
879 unbind_to (speccount, Qnil);
884 Lisp_Object arg = POP;
885 TOP = Fcar (Fnthcdr (TOP, arg));
890 TOP = SYMBOLP (TOP) ? Qt : Qnil;
894 TOP = CONSP (TOP) ? Qt : Qnil;
898 TOP = STRINGP (TOP) ? Qt : Qnil;
902 TOP = LISTP (TOP) ? Qt : Qnil;
906 TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
910 TOP = INTP (TOP) ? Qt : Qnil;
915 Lisp_Object arg = POP;
916 TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
921 TOP = NILP (TOP) ? Qt : Qnil;
926 Lisp_Object arg = POP;
927 TOP = Fcons (TOP, arg);
932 TOP = Fcons (TOP, Qnil);
944 n = opcode - (Blist1 - 1);
947 Lisp_Object list = Qnil;
949 list = Fcons (TOP, list);
963 n = opcode - (Bconcat2 - 2);
971 TOP = Fconcat (n, &TOP);
981 Lisp_Object arg2 = POP;
982 Lisp_Object arg1 = POP;
983 TOP = Faset (TOP, arg1, arg2);
988 TOP = Fsymbol_value (TOP);
991 case Bsymbol_function:
992 TOP = Fsymbol_function (TOP);
997 Lisp_Object arg = POP;
998 TOP = Fget (TOP, arg, Qnil);
1003 TOP = INTP (TOP) ? make_int (XINT (TOP) - 1) : Fsub1 (TOP);
1007 TOP = INTP (TOP) ? make_int (XINT (TOP) + 1) : Fadd1 (TOP);
1013 Lisp_Object arg = POP;
1014 TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
1020 Lisp_Object arg = POP;
1021 TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
1027 Lisp_Object arg = POP;
1028 TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
1034 Lisp_Object arg = POP;
1035 TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
1041 Lisp_Object arg = POP;
1042 TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
1048 TOP = bytecode_negate (TOP);
1053 TOP = bytecode_nconc2 (&TOP);
1058 Lisp_Object arg2 = POP;
1059 Lisp_Object arg1 = TOP;
1060 TOP = INTP (arg1) && INTP (arg2) ?
1061 make_int (XINT (arg1) + XINT (arg2)) :
1062 bytecode_arithop (arg1, arg2, opcode);
1068 Lisp_Object arg2 = POP;
1069 Lisp_Object arg1 = TOP;
1070 TOP = INTP (arg1) && INTP (arg2) ?
1071 make_int (XINT (arg1) - XINT (arg2)) :
1072 bytecode_arithop (arg1, arg2, opcode);
1081 Lisp_Object arg = POP;
1082 TOP = bytecode_arithop (TOP, arg, opcode);
1087 PUSH (make_int (BUF_PT (current_buffer)));
1091 TOP = Finsert (1, &TOP);
1097 TOP = Finsert (n, &TOP);
1102 Lisp_Object arg = POP;
1103 TOP = Faref (TOP, arg);
1109 Lisp_Object arg = POP;
1110 TOP = Fmemq (TOP, arg);
1117 Lisp_Object arg = POP;
1118 TOP = Fset (TOP, arg);
1124 Lisp_Object arg = POP;
1125 TOP = Fequal (TOP, arg);
1131 Lisp_Object arg = POP;
1132 TOP = Fnthcdr (TOP, arg);
1138 Lisp_Object arg = POP;
1139 TOP = Felt (TOP, arg);
1145 Lisp_Object arg = POP;
1146 TOP = Fmember (TOP, arg);
1151 TOP = Fgoto_char (TOP, Qnil);
1154 case Bcurrent_buffer:
1157 XSETBUFFER (buffer, current_buffer);
1163 TOP = Fset_buffer (TOP);
1167 PUSH (make_int (BUF_ZV (current_buffer)));
1171 PUSH (make_int (BUF_BEGV (current_buffer)));
1174 case Bskip_chars_forward:
1176 Lisp_Object arg = POP;
1177 TOP = Fskip_chars_forward (TOP, arg, Qnil);
1183 Lisp_Object arg = POP;
1184 TOP = Fassq (TOP, arg);
1190 Lisp_Object arg = POP;
1191 TOP = Fsetcar (TOP, arg);
1197 Lisp_Object arg = POP;
1198 TOP = Fsetcdr (TOP, arg);
1203 TOP = bytecode_nreverse (TOP);
1207 TOP = CONSP (TOP) ? XCAR (TOP) : Qnil;
1211 TOP = CONSP (TOP) ? XCDR (TOP) : Qnil;
1218 /* It makes a worthwhile performance difference (5%) to shunt
1219 lesser-used opcodes off to a subroutine, to keep the switch in
1220 execute_optimized_program small. If you REALLY care about
1221 performance, you want to keep your heavily executed code away from
1222 rarely executed code, to minimize cache misses.
1224 Don't make this function static, since then the compiler might inline it. */
1226 execute_rare_opcode (Lisp_Object *stack_ptr,
1227 CONST Opbyte *program_ptr,
1233 case Bsave_excursion:
1234 record_unwind_protect (save_excursion_restore,
1235 save_excursion_save ());
1238 case Bsave_window_excursion:
1240 int count = specpdl_depth ();
1241 record_unwind_protect (save_window_excursion_unwind,
1242 Fcurrent_window_configuration (Qnil));
1244 unbind_to (count, Qnil);
1248 case Bsave_restriction:
1249 record_unwind_protect (save_restriction_restore,
1250 save_restriction_save ());
1255 Lisp_Object arg = POP;
1256 TOP = internal_catch (TOP, Feval, arg, 0);
1260 case Bskip_chars_backward:
1262 Lisp_Object arg = POP;
1263 TOP = Fskip_chars_backward (TOP, arg, Qnil);
1267 case Bunwind_protect:
1268 record_unwind_protect (Fprogn, POP);
1271 case Bcondition_case:
1273 Lisp_Object arg2 = POP; /* handlers */
1274 Lisp_Object arg1 = POP; /* bodyform */
1275 TOP = condition_case_3 (arg1, TOP, arg2);
1281 Lisp_Object arg2 = POP;
1282 Lisp_Object arg1 = POP;
1283 TOP = Fset_marker (TOP, arg1, arg2);
1289 Lisp_Object arg = POP;
1290 TOP = Frem (TOP, arg);
1294 case Bmatch_beginning:
1295 TOP = Fmatch_beginning (TOP);
1299 TOP = Fmatch_end (TOP);
1303 TOP = Fupcase (TOP, Qnil);
1307 TOP = Fdowncase (TOP, Qnil);
1312 Lisp_Object arg = POP;
1313 TOP = Ffset (TOP, arg);
1319 Lisp_Object arg = POP;
1320 TOP = Fstring_equal (TOP, arg);
1326 Lisp_Object arg = POP;
1327 TOP = Fstring_lessp (TOP, arg);
1333 Lisp_Object arg2 = POP;
1334 Lisp_Object arg1 = POP;
1335 TOP = Fsubstring (TOP, arg1, arg2);
1339 case Bcurrent_column:
1340 PUSH (make_int (current_column (current_buffer)));
1344 TOP = Fchar_after (TOP, Qnil);
1348 TOP = Findent_to (TOP, Qnil, Qnil);
1352 PUSH (Fwiden (Qnil));
1355 case Bfollowing_char:
1356 PUSH (Ffollowing_char (Qnil));
1359 case Bpreceding_char:
1360 PUSH (Fpreceding_char (Qnil));
1364 PUSH (Feolp (Qnil));
1368 PUSH (Feobp (Qnil));
1372 PUSH (Fbolp (Qnil));
1376 PUSH (Fbobp (Qnil));
1379 case Bsave_current_buffer:
1380 record_unwind_protect (save_current_buffer_restore,
1381 Fcurrent_buffer ());
1384 case Binteractive_p:
1385 PUSH (Finteractive_p ());
1389 TOP = Fforward_char (TOP, Qnil);
1393 TOP = Fforward_word (TOP, Qnil);
1397 TOP = Fforward_line (TOP, Qnil);
1401 TOP = Fchar_syntax (TOP, Qnil);
1404 case Bbuffer_substring:
1406 Lisp_Object arg = POP;
1407 TOP = Fbuffer_substring (TOP, arg, Qnil);
1411 case Bdelete_region:
1413 Lisp_Object arg = POP;
1414 TOP = Fdelete_region (TOP, arg, Qnil);
1418 case Bnarrow_to_region:
1420 Lisp_Object arg = POP;
1421 TOP = Fnarrow_to_region (TOP, arg, Qnil);
1426 TOP = Fend_of_line (TOP, Qnil);
1429 case Btemp_output_buffer_setup:
1430 temp_output_buffer_setup (TOP);
1431 TOP = Vstandard_output;
1434 case Btemp_output_buffer_show:
1436 Lisp_Object arg = POP;
1437 temp_output_buffer_show (TOP, Qnil);
1440 /* pop binding of standard-output */
1441 unbind_to (specpdl_depth() - 1, Qnil);
1447 Lisp_Object arg = POP;
1448 TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
1454 Lisp_Object arg = POP;
1455 TOP = Fold_memq (TOP, arg);
1461 Lisp_Object arg = POP;
1462 TOP = Fold_equal (TOP, arg);
1468 Lisp_Object arg = POP;
1469 TOP = Fold_member (TOP, arg);
1475 Lisp_Object arg = POP;
1476 TOP = Fold_assq (TOP, arg);
1489 invalid_byte_code_error (char *error_message, ...)
1493 char *buf = alloca_array (char, strlen (error_message) + 128);
1495 sprintf (buf, "%s", error_message);
1496 va_start (args, error_message);
1497 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (buf), Qnil, -1,
1501 signal_error (Qinvalid_byte_code, list1 (obj));
1504 /* Check for valid opcodes. Change this when adding new opcodes. */
1506 check_opcode (Opcode opcode)
1508 if ((opcode < Bvarref) ||
1510 (opcode > Bassq && opcode < Bconstant))
1511 invalid_byte_code_error
1512 ("invalid opcode %d in instruction stream", opcode);
1515 /* Check that IDX is a valid offset into the `constants' vector */
1517 check_constants_index (int idx, Lisp_Object constants)
1519 if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
1520 invalid_byte_code_error
1521 ("reference %d to constants array out of range 0, %d",
1522 idx, XVECTOR_LENGTH (constants) - 1);
1525 /* Get next character from Lisp instructions string. */
1526 #define READ_INSTRUCTION_CHAR(lvalue) do { \
1527 (lvalue) = charptr_emchar (ptr); \
1528 INC_CHARPTR (ptr); \
1529 *icounts_ptr++ = program_ptr - program; \
1530 if (lvalue > UCHAR_MAX) \
1531 invalid_byte_code_error \
1532 ("Invalid character %c in byte code string"); \
1535 /* Get opcode from Lisp instructions string. */
1536 #define READ_OPCODE do { \
1538 READ_INSTRUCTION_CHAR (c); \
1539 opcode = (Opcode) c; \
1542 /* Get next operand, a uint8, from Lisp instructions string. */
1543 #define READ_OPERAND_1 do { \
1544 READ_INSTRUCTION_CHAR (arg); \
1548 /* Get next operand, a uint16, from Lisp instructions string. */
1549 #define READ_OPERAND_2 do { \
1550 unsigned int arg1, arg2; \
1551 READ_INSTRUCTION_CHAR (arg1); \
1552 READ_INSTRUCTION_CHAR (arg2); \
1553 arg = arg1 + (arg2 << 8); \
1557 /* Write 1 byte to PTR, incrementing PTR */
1558 #define WRITE_INT8(value, ptr) do { \
1559 *((ptr)++) = (value); \
1562 /* Write 2 bytes to PTR, incrementing PTR */
1563 #define WRITE_INT16(value, ptr) do { \
1564 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \
1565 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \
1568 /* We've changed our minds about the opcode we've already written. */
1569 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
1571 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
1572 #define WRITE_NARGS(base_opcode) do { \
1575 REWRITE_OPCODE (base_opcode + arg); \
1577 else if (arg <= UCHAR_MAX) \
1579 REWRITE_OPCODE (base_opcode + 6); \
1580 WRITE_INT8 (arg, program_ptr); \
1584 REWRITE_OPCODE (base_opcode + 7); \
1585 WRITE_INT16 (arg, program_ptr); \
1589 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
1590 #define WRITE_CONSTANT do { \
1591 check_constants_index(arg, constants); \
1592 if (arg <= UCHAR_MAX - Bconstant) \
1594 REWRITE_OPCODE (Bconstant + arg); \
1598 REWRITE_OPCODE (Bconstant2); \
1599 WRITE_INT16 (arg, program_ptr); \
1603 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
1605 /* Compile byte code instructions into free space provided by caller, with
1606 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
1607 Returns length of compiled code. */
1609 optimize_byte_code (/* in */
1610 Lisp_Object instructions,
1611 Lisp_Object constants,
1613 Opbyte * CONST program,
1614 int * CONST program_length,
1615 int * CONST varbind_count)
1617 size_t instructions_length = XSTRING_LENGTH (instructions);
1618 size_t comfy_size = 2 * instructions_length;
1620 int * CONST icounts = alloca_array (int, comfy_size);
1621 int * icounts_ptr = icounts;
1623 /* We maintain a table of jumps in the source code. */
1629 struct jump * CONST jumps = alloca_array (struct jump, comfy_size);
1630 struct jump *jumps_ptr = jumps;
1632 Opbyte *program_ptr = program;
1634 CONST Bufbyte *ptr = XSTRING_DATA (instructions);
1635 CONST Bufbyte * CONST end = ptr + instructions_length;
1651 case Bvarref+7: READ_OPERAND_2; goto do_varref;
1652 case Bvarref+6: READ_OPERAND_1; goto do_varref;
1653 case Bvarref: case Bvarref+1: case Bvarref+2:
1654 case Bvarref+3: case Bvarref+4: case Bvarref+5:
1655 arg = opcode - Bvarref;
1657 check_constants_index (arg, constants);
1658 val = XVECTOR_DATA (constants) [arg];
1660 invalid_byte_code_error ("variable reference to non-symbol %S", val);
1661 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1662 invalid_byte_code_error ("variable reference to constant symbol %s",
1663 string_data (XSYMBOL (val)->name));
1664 WRITE_NARGS (Bvarref);
1667 case Bvarset+7: READ_OPERAND_2; goto do_varset;
1668 case Bvarset+6: READ_OPERAND_1; goto do_varset;
1669 case Bvarset: case Bvarset+1: case Bvarset+2:
1670 case Bvarset+3: case Bvarset+4: case Bvarset+5:
1671 arg = opcode - Bvarset;
1673 check_constants_index (arg, constants);
1674 val = XVECTOR_DATA (constants) [arg];
1676 invalid_byte_code_error ("attempt to set non-symbol %S", val);
1677 if (EQ (val, Qnil) || EQ (val, Qt))
1678 invalid_byte_code_error ("attempt to set constant symbol %s",
1679 string_data (XSYMBOL (val)->name));
1680 /* Ignore assignments to keywords by converting to Bdiscard.
1681 For backward compatibility only - we'd like to make this an error. */
1682 if (SYMBOL_IS_KEYWORD (val))
1683 REWRITE_OPCODE (Bdiscard);
1685 WRITE_NARGS (Bvarset);
1688 case Bvarbind+7: READ_OPERAND_2; goto do_varbind;
1689 case Bvarbind+6: READ_OPERAND_1; goto do_varbind;
1690 case Bvarbind: case Bvarbind+1: case Bvarbind+2:
1691 case Bvarbind+3: case Bvarbind+4: case Bvarbind+5:
1692 arg = opcode - Bvarbind;
1695 check_constants_index (arg, constants);
1696 val = XVECTOR_DATA (constants) [arg];
1698 invalid_byte_code_error ("attempt to let-bind non-symbol %S", val);
1699 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
1700 invalid_byte_code_error ("attempt to let-bind constant symbol %s",
1701 string_data (XSYMBOL (val)->name));
1702 WRITE_NARGS (Bvarbind);
1705 case Bcall+7: READ_OPERAND_2; goto do_call;
1706 case Bcall+6: READ_OPERAND_1; goto do_call;
1707 case Bcall: case Bcall+1: case Bcall+2:
1708 case Bcall+3: case Bcall+4: case Bcall+5:
1709 arg = opcode - Bcall;
1711 WRITE_NARGS (Bcall);
1714 case Bunbind+7: READ_OPERAND_2; goto do_unbind;
1715 case Bunbind+6: READ_OPERAND_1; goto do_unbind;
1716 case Bunbind: case Bunbind+1: case Bunbind+2:
1717 case Bunbind+3: case Bunbind+4: case Bunbind+5:
1718 arg = opcode - Bunbind;
1720 WRITE_NARGS (Bunbind);
1726 case Bgotoifnilelsepop:
1727 case Bgotoifnonnilelsepop:
1729 /* Make program_ptr-relative */
1730 arg += icounts - (icounts_ptr - argsize);
1735 case BRgotoifnonnil:
1736 case BRgotoifnilelsepop:
1737 case BRgotoifnonnilelsepop:
1739 /* Make program_ptr-relative */
1742 /* Record program-relative goto addresses in `jumps' table */
1743 jumps_ptr->from = icounts_ptr - icounts - argsize;
1744 jumps_ptr->to = jumps_ptr->from + arg;
1746 if (arg >= -1 && arg <= argsize)
1747 invalid_byte_code_error
1748 ("goto instruction is its own target");
1749 if (arg <= SCHAR_MIN ||
1753 REWRITE_OPCODE (opcode + Bgoto - BRgoto);
1754 WRITE_INT16 (arg, program_ptr);
1759 REWRITE_OPCODE (opcode + BRgoto - Bgoto);
1760 WRITE_INT8 (arg, program_ptr);
1773 WRITE_INT8 (arg, program_ptr);
1777 if (opcode < Bconstant)
1778 check_opcode (opcode);
1781 arg = opcode - Bconstant;
1788 /* Fix up jumps table to refer to NEW offsets. */
1791 for (j = jumps; j < jumps_ptr; j++)
1793 #ifdef ERROR_CHECK_BYTE_CODE
1794 assert (j->from < icounts_ptr - icounts);
1795 assert (j->to < icounts_ptr - icounts);
1797 j->from = icounts[j->from];
1798 j->to = icounts[j->to];
1799 #ifdef ERROR_CHECK_BYTE_CODE
1800 assert (j->from < program_ptr - program);
1801 assert (j->to < program_ptr - program);
1802 check_opcode ((Opcode) (program[j->from-1]));
1804 check_opcode ((Opcode) (program[j->to]));
1808 /* Fixup jumps in byte-code until no more fixups needed */
1810 int more_fixups_needed = 1;
1812 while (more_fixups_needed)
1815 more_fixups_needed = 0;
1816 for (j = jumps; j < jumps_ptr; j++)
1820 int jump = to - from;
1821 Opbyte *p = program + from;
1822 Opcode opcode = (Opcode) p[-1];
1823 if (!more_fixups_needed)
1824 check_opcode ((Opcode) p[jump]);
1825 assert (to >= 0 && program + to < program_ptr);
1831 case Bgotoifnilelsepop:
1832 case Bgotoifnonnilelsepop:
1833 WRITE_INT16 (jump, p);
1838 case BRgotoifnonnil:
1839 case BRgotoifnilelsepop:
1840 case BRgotoifnonnilelsepop:
1841 if (jump > SCHAR_MIN &&
1844 WRITE_INT8 (jump, p);
1849 for (jj = jumps; jj < jumps_ptr; jj++)
1851 assert (jj->from < program_ptr - program);
1852 assert (jj->to < program_ptr - program);
1853 if (jj->from > from) jj->from++;
1854 if (jj->to > from) jj->to++;
1856 p[-1] += Bgoto - BRgoto;
1857 more_fixups_needed = 1;
1858 memmove (p+1, p, program_ptr++ - p);
1859 WRITE_INT16 (jump, p);
1871 /* *program_ptr++ = 0; */
1872 *program_length = program_ptr - program;
1875 /* Optimize the byte code and store the optimized program, only
1876 understood by bytecode.c, in an opaque object in the
1877 instructions slot of the Compiled_Function object. */
1879 optimize_compiled_function (Lisp_Object compiled_function)
1881 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
1886 /* If we have not actually read the bytecode string
1887 and constants vector yet, fetch them from the file. */
1888 if (CONSP (f->instructions))
1889 Ffetch_bytecode (compiled_function);
1891 if (STRINGP (f->instructions))
1893 /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1894 which would be slightly more `proper' */
1895 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
1896 optimize_byte_code (f->instructions, f->constants,
1897 program, &program_length, &varbind_count);
1898 f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
1900 Fpurecopy (make_opaque (program_length * sizeof (Opbyte),
1901 (CONST void *) program));
1904 assert (OPAQUEP (f->instructions));
1907 /************************************************************************/
1908 /* The compiled-function object type */
1909 /************************************************************************/
1911 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
1914 /* This function can GC */
1915 Lisp_Compiled_Function *f =
1916 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
1917 int docp = f->flags.documentationp;
1918 int intp = f->flags.interactivep;
1919 struct gcpro gcpro1, gcpro2;
1921 GCPRO2 (obj, printcharfun);
1923 write_c_string (print_readably ? "#[" : "#<compiled-function ", printcharfun);
1924 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1925 if (!print_readably)
1927 Lisp_Object ann = compiled_function_annotation (f);
1930 write_c_string ("(from ", printcharfun);
1931 print_internal (ann, printcharfun, 1);
1932 write_c_string (") ", printcharfun);
1935 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1936 /* COMPILED_ARGLIST = 0 */
1937 print_internal (compiled_function_arglist (f), printcharfun, escapeflag);
1939 /* COMPILED_INSTRUCTIONS = 1 */
1940 write_c_string (" ", printcharfun);
1942 struct gcpro ngcpro1;
1943 Lisp_Object instructions = compiled_function_instructions (f);
1944 NGCPRO1 (instructions);
1945 if (STRINGP (instructions) && !print_readably)
1947 /* We don't usually want to see that junk in the bytecode. */
1948 sprintf (buf, "\"...(%ld)\"",
1949 (long) XSTRING_CHAR_LENGTH (instructions));
1950 write_c_string (buf, printcharfun);
1953 print_internal (instructions, printcharfun, escapeflag);
1957 /* COMPILED_CONSTANTS = 2 */
1958 write_c_string (" ", printcharfun);
1959 print_internal (compiled_function_constants (f), printcharfun, escapeflag);
1961 /* COMPILED_STACK_DEPTH = 3 */
1962 sprintf (buf, " %d", compiled_function_stack_depth (f));
1963 write_c_string (buf, printcharfun);
1965 /* COMPILED_DOC_STRING = 4 */
1968 write_c_string (" ", printcharfun);
1969 print_internal (compiled_function_documentation (f), printcharfun,
1973 /* COMPILED_INTERACTIVE = 5 */
1976 write_c_string (" ", printcharfun);
1977 print_internal (compiled_function_interactive (f), printcharfun,
1982 write_c_string (print_readably ? "]" : ">", printcharfun);
1987 mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object))
1989 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1991 markobj (f->instructions);
1992 markobj (f->arglist);
1993 markobj (f->doc_and_interactive);
1994 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1995 markobj (f->annotated);
1997 /* tail-recurse on constants */
1998 return f->constants;
2002 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2004 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1);
2005 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
2007 (f1->flags.documentationp == f2->flags.documentationp &&
2008 f1->flags.interactivep == f2->flags.interactivep &&
2009 f1->flags.domainp == f2->flags.domainp && /* I18N3 */
2010 internal_equal (compiled_function_instructions (f1),
2011 compiled_function_instructions (f2), depth + 1) &&
2012 internal_equal (f1->constants, f2->constants, depth + 1) &&
2013 internal_equal (f1->arglist, f2->arglist, depth + 1) &&
2014 internal_equal (f1->doc_and_interactive,
2015 f2->doc_and_interactive, depth + 1));
2018 static unsigned long
2019 compiled_function_hash (Lisp_Object obj, int depth)
2021 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
2022 return HASH3 ((f->flags.documentationp << 2) +
2023 (f->flags.interactivep << 1) +
2025 internal_hash (f->instructions, depth + 1),
2026 internal_hash (f->constants, depth + 1));
2029 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
2030 mark_compiled_function,
2031 print_compiled_function, 0,
2032 compiled_function_equal,
2033 compiled_function_hash,
2034 Lisp_Compiled_Function);
2036 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
2037 Return t if OBJECT is a byte-compiled function object.
2041 return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
2044 /************************************************************************/
2045 /* compiled-function object accessor functions */
2046 /************************************************************************/
2049 compiled_function_arglist (Lisp_Compiled_Function *f)
2055 compiled_function_instructions (Lisp_Compiled_Function *f)
2057 if (! OPAQUEP (f->instructions))
2058 return f->instructions;
2061 /* Invert action performed by optimize_byte_code() */
2062 Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2064 Bufbyte * CONST buffer =
2065 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2066 Bufbyte *bp = buffer;
2068 CONST Opbyte * CONST program = (CONST Opbyte *) OPAQUE_DATA (opaque);
2069 CONST Opbyte *program_ptr = program;
2070 CONST Opbyte * CONST program_end = program_ptr + OPAQUE_SIZE (opaque);
2072 while (program_ptr < program_end)
2074 Opcode opcode = (Opcode) READ_UINT_1;
2075 bp += set_charptr_emchar (bp, opcode);
2084 bp += set_charptr_emchar (bp, READ_UINT_1);
2085 bp += set_charptr_emchar (bp, READ_UINT_1);
2096 bp += set_charptr_emchar (bp, READ_UINT_1);
2102 case Bgotoifnilelsepop:
2103 case Bgotoifnonnilelsepop:
2105 int jump = READ_INT_2;
2107 Opbyte *buf2p = buf2;
2108 /* Convert back to program-relative address */
2109 WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
2110 bp += set_charptr_emchar (bp, buf2[0]);
2111 bp += set_charptr_emchar (bp, buf2[1]);
2117 case BRgotoifnonnil:
2118 case BRgotoifnilelsepop:
2119 case BRgotoifnonnilelsepop:
2120 bp += set_charptr_emchar (bp, READ_INT_1 + 127);
2127 return make_string (buffer, bp - buffer);
2132 compiled_function_constants (Lisp_Compiled_Function *f)
2134 return f->constants;
2138 compiled_function_stack_depth (Lisp_Compiled_Function *f)
2140 return f->stack_depth;
2143 /* The compiled_function->doc_and_interactive slot uses the minimal
2144 number of conses, based on compiled_function->flags; it may take
2145 any of the following forms:
2152 (interactive . domain)
2153 (doc . (interactive . domain))
2156 /* Caller must check flags.interactivep first */
2158 compiled_function_interactive (Lisp_Compiled_Function *f)
2160 assert (f->flags.interactivep);
2161 if (f->flags.documentationp && f->flags.domainp)
2162 return XCAR (XCDR (f->doc_and_interactive));
2163 else if (f->flags.documentationp)
2164 return XCDR (f->doc_and_interactive);
2165 else if (f->flags.domainp)
2166 return XCAR (f->doc_and_interactive);
2168 return f->doc_and_interactive;
2171 /* Caller need not check flags.documentationp first */
2173 compiled_function_documentation (Lisp_Compiled_Function *f)
2175 if (! f->flags.documentationp)
2177 else if (f->flags.interactivep && f->flags.domainp)
2178 return XCAR (f->doc_and_interactive);
2179 else if (f->flags.interactivep)
2180 return XCAR (f->doc_and_interactive);
2181 else if (f->flags.domainp)
2182 return XCAR (f->doc_and_interactive);
2184 return f->doc_and_interactive;
2187 /* Caller need not check flags.domainp first */
2189 compiled_function_domain (Lisp_Compiled_Function *f)
2191 if (! f->flags.domainp)
2193 else if (f->flags.documentationp && f->flags.interactivep)
2194 return XCDR (XCDR (f->doc_and_interactive));
2195 else if (f->flags.documentationp)
2196 return XCDR (f->doc_and_interactive);
2197 else if (f->flags.interactivep)
2198 return XCDR (f->doc_and_interactive);
2200 return f->doc_and_interactive;
2203 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2206 compiled_function_annotation (Lisp_Compiled_Function *f)
2208 return f->annotated;
2213 /* used only by Snarf-documentation; there must be doc already. */
2215 set_compiled_function_documentation (Lisp_Compiled_Function *f,
2216 Lisp_Object new_doc)
2218 assert (f->flags.documentationp);
2219 assert (INTP (new_doc) || STRINGP (new_doc));
2221 if (f->flags.interactivep && f->flags.domainp)
2222 XCAR (f->doc_and_interactive) = new_doc;
2223 else if (f->flags.interactivep)
2224 XCAR (f->doc_and_interactive) = new_doc;
2225 else if (f->flags.domainp)
2226 XCAR (f->doc_and_interactive) = new_doc;
2228 f->doc_and_interactive = new_doc;
2232 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2233 Return the argument list of the compiled-function object FUNCTION.
2237 CHECK_COMPILED_FUNCTION (function);
2238 return compiled_function_arglist (XCOMPILED_FUNCTION (function));
2241 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
2242 Return the byte-opcode string of the compiled-function object FUNCTION.
2246 CHECK_COMPILED_FUNCTION (function);
2247 return compiled_function_instructions (XCOMPILED_FUNCTION (function));
2250 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
2251 Return the constants vector of the compiled-function object FUNCTION.
2255 CHECK_COMPILED_FUNCTION (function);
2256 return compiled_function_constants (XCOMPILED_FUNCTION (function));
2259 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2260 Return the max stack depth of the compiled-function object FUNCTION.
2264 CHECK_COMPILED_FUNCTION (function);
2265 return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
2268 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
2269 Return the doc string of the compiled-function object FUNCTION, if available.
2270 Functions that had their doc strings snarfed into the DOC file will have
2271 an integer returned instead of a string.
2275 CHECK_COMPILED_FUNCTION (function);
2276 return compiled_function_documentation (XCOMPILED_FUNCTION (function));
2279 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2280 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2281 If non-nil, the return value will be a list whose first element is
2282 `interactive' and whose second element is the interactive spec.
2286 CHECK_COMPILED_FUNCTION (function);
2287 return XCOMPILED_FUNCTION (function)->flags.interactivep
2288 ? list2 (Qinteractive,
2289 compiled_function_interactive (XCOMPILED_FUNCTION (function)))
2293 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2295 /* Remove the `xx' if you wish to restore this feature */
2296 xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2297 Return the annotation of the compiled-function object FUNCTION, or nil.
2298 The annotation is a piece of information indicating where this
2299 compiled-function object came from. Generally this will be
2300 a symbol naming a function; or a string naming a file, if the
2301 compiled-function object was not defined in a function; or nil,
2302 if the compiled-function object was not created as a result of
2307 CHECK_COMPILED_FUNCTION (function);
2308 return compiled_function_annotation (XCOMPILED_FUNCTION (function));
2311 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2313 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
2314 Return the domain of the compiled-function object FUNCTION, or nil.
2315 This is only meaningful if I18N3 was enabled when emacs was compiled.
2319 CHECK_COMPILED_FUNCTION (function);
2320 return XCOMPILED_FUNCTION (function)->flags.domainp
2321 ? compiled_function_domain (XCOMPILED_FUNCTION (function))
2327 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
2328 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2332 Lisp_Compiled_Function *f;
2333 CHECK_COMPILED_FUNCTION (function);
2334 f = XCOMPILED_FUNCTION (function);
2336 if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
2339 if (CONSP (f->instructions))
2341 Lisp_Object tem = read_doc_string (f->instructions);
2343 signal_simple_error ("Invalid lazy-loaded byte code", tem);
2344 /* v18 or v19 bytecode file. Need to Ebolify. */
2345 if (f->flags.ebolified && VECTORP (XCDR (tem)))
2346 ebolify_bytecode_constants (XCDR (tem));
2347 /* VERY IMPORTANT to purecopy here!!!!!
2348 See load_force_doc_string_unwind. */
2349 f->instructions = Fpurecopy (XCAR (tem));
2350 f->constants = Fpurecopy (XCDR (tem));
2354 return Qnil; /* not reached */
2357 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
2358 Convert compiled function FUNCTION into an optimized internal form.
2362 Lisp_Compiled_Function *f;
2363 CHECK_COMPILED_FUNCTION (function);
2364 f = XCOMPILED_FUNCTION (function);
2366 if (OPAQUEP (f->instructions)) /* Already optimized? */
2369 optimize_compiled_function (function);
2373 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
2374 Function used internally in byte-compiled code.
2375 First argument INSTRUCTIONS is a string of byte code.
2376 Second argument CONSTANTS is a vector of constants.
2377 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2378 If STACK-DEPTH is incorrect, Emacs may crash.
2380 (instructions, constants, stack_depth))
2382 /* This function can GC */
2387 CHECK_STRING (instructions);
2388 CHECK_VECTOR (constants);
2389 CHECK_NATNUM (stack_depth);
2391 /* Optimize the `instructions' string, just like when executing a
2392 regular compiled function, but don't save it for later since this is
2393 likely to only be executed once. */
2394 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
2395 optimize_byte_code (instructions, constants, program,
2396 &program_length, &varbind_count);
2397 SPECPDL_RESERVE (varbind_count);
2398 return execute_optimized_program (program,
2400 XVECTOR_DATA (constants));
2405 syms_of_bytecode (void)
2407 deferror (&Qinvalid_byte_code, "invalid-byte-code",
2408 "Invalid byte code", Qerror);
2409 defsymbol (&Qbyte_code, "byte-code");
2410 defsymbol (&Qcompiled_functionp, "compiled-function-p");
2412 DEFSUBR (Fbyte_code);
2413 DEFSUBR (Ffetch_bytecode);
2414 DEFSUBR (Foptimize_compiled_function);
2416 DEFSUBR (Fcompiled_function_p);
2417 DEFSUBR (Fcompiled_function_instructions);
2418 DEFSUBR (Fcompiled_function_constants);
2419 DEFSUBR (Fcompiled_function_stack_depth);
2420 DEFSUBR (Fcompiled_function_arglist);
2421 DEFSUBR (Fcompiled_function_interactive);
2422 DEFSUBR (Fcompiled_function_doc_string);
2423 DEFSUBR (Fcompiled_function_domain);
2424 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2425 DEFSUBR (Fcompiled_function_annotation);
2428 #ifdef BYTE_CODE_METER
2429 defsymbol (&Qbyte_code_meter, "byte-code-meter");
2434 vars_of_bytecode (void)
2436 #ifdef BYTE_CODE_METER
2438 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
2439 A vector of vectors which holds a histogram of byte code usage.
2440 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2441 opcode CODE has been executed.
2442 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2443 indicates how many times the byte opcodes CODE1 and CODE2 have been
2444 executed in succession.
2446 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /*
2447 If non-nil, keep profiling information on byte code usage.
2448 The variable `byte-code-meter' indicates how often each byte opcode is used.
2449 If a symbol has a property named `byte-code-meter' whose value is an
2450 integer, it is incremented each time that symbol's function is called.
2453 byte_metering_on = 0;
2454 Vbyte_code_meter = make_vector (256, Qzero);
2458 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
2460 #endif /* BYTE_CODE_METER */