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 SXEmacs
7 SXEmacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 SXEmacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
21 /* Synched up with: Mule 2.0, FSF 19.30. */
23 /* This file has been Mule-ized. */
29 hacked on by jwz@jwz.org 1991-06
30 o added a compile-time switch to turn on simple sanity checking;
31 o put back the obsolete byte-codes for error-detection;
32 o added a new instruction, unbind_all, which I will use for
33 tail-recursion elimination;
34 o made temp_output_buffer_show be called with the right number
36 o made the new bytecodes be called with args in the right order;
37 o added metering support.
40 o added relative jump instructions;
41 o all conditionals now only do QUIT if they jump.
43 Ben Wing: some changes for Mule, 1995-06.
45 Martin Buchholz: performance hacking, 1998-09.
46 See Internals Manual, Evaluation.
51 #include "backtrace.h"
58 EXFUN(Ffetch_bytecode, 1);
60 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
62 enum Opcode { /* Byte codes */
88 Bsymbol_function = 0113,
111 Beq = 0141, /* was Bmark,
112 but no longer generated as of v18 */
118 Bfollowing_char = 0147,
119 Bpreceding_char = 0150,
120 Bcurrent_column = 0151,
122 Bequal = 0153, /* was Bscan_buffer,
123 but no longer generated as of v18 */
128 Bcurrent_buffer = 0160,
130 Bsave_current_buffer = 0162, /* was Bread_char,
131 but no longer generated as of v19 */
132 Bmemq = 0163, /* was Bset_mark,
133 but no longer generated as of v18 */
134 Binteractive_p = 0164, /* Needed since interactive-p takes
136 Bforward_char = 0165,
137 Bforward_word = 0166,
138 Bskip_chars_forward = 0167,
139 Bskip_chars_backward = 0170,
140 Bforward_line = 0171,
142 Bbuffer_substring = 0173,
143 Bdelete_region = 0174,
144 Bnarrow_to_region = 0175,
151 Bgotoifnonnil = 0204,
152 Bgotoifnilelsepop = 0205,
153 Bgotoifnonnilelsepop = 0206,
158 Bsave_excursion = 0212,
159 Bsave_window_excursion = 0213,
160 Bsave_restriction = 0214,
163 Bunwind_protect = 0216,
164 Bcondition_case = 0217,
165 Btemp_output_buffer_setup = 0220,
166 Btemp_output_buffer_show = 0221,
171 Bmatch_beginning = 0224,
176 Bstring_equal = 0230,
177 Bstring_lessp = 0231,
196 BRgotoifnonnil = 0254,
197 BRgotoifnilelsepop = 0255,
198 BRgotoifnonnilelsepop = 0256,
203 Bmember = 0266, /* new in v20 */
204 Bassq = 0267, /* new in v20 */
206 Bcl_macro = 0270, /* only if modules/cl is there */
208 BLAST_BEFORE_THREE_O_O = Bcl_macro,
212 typedef enum Opcode Opcode;
213 typedef unsigned char Opbyte;
215 static void check_opcode(Opcode opcode);
216 static void invalid_byte_code_error(char *error_message, ...);
219 execute_rare_opcode(Lisp_Object *stk, const Opbyte *prg, Opcode opcode)
220 __attribute__((noinline));
222 static Lisp_Object execute_optimized_program(const Opbyte * program,
224 Lisp_Object * constants_data);
226 extern Lisp_Object Qand_rest, Qand_optional;
228 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
229 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
230 /* #define BYTE_CODE_METER */
232 #ifdef BYTE_CODE_METER
234 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
235 int byte_metering_on;
237 static void meter_code(Opcode prev_opcode, Opcode this_opcode)
239 if (byte_metering_on) {
241 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 */
250 static Lisp_Object bytecode_nreverse(Lisp_Object list)
252 REGISTER Lisp_Object prev = Qnil;
253 REGISTER Lisp_Object tail = list;
255 while (!NILP(tail)) {
256 REGISTER Lisp_Object next;
266 /* Apply compiled-function object FUN to the NARGS evaluated arguments
267 in ARGS, and return the result of evaluation. */
269 funcall_compiled_function(Lisp_Object fun, int nargs, Lisp_Object args[])
271 /* This function can GC */
272 int speccount = specpdl_depth();
274 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(fun);
277 if (!OPAQUEP(f->instructions))
278 /* Lazily munge the instructions into a more efficient form */
279 optimize_compiled_function(fun);
281 /* optimize_compiled_function() guaranteed that f->specpdl_depth is
282 the required space on the specbinding stack for binding the args
283 and local variables of fun. So just reserve it once. */
284 SPECPDL_RESERVE(f->specpdl_depth);
287 /* Fmake_byte_code() guaranteed that f->arglist is a valid list
288 containing only non-constant symbols. */
289 LIST_LOOP_3(symbol, f->arglist, tail) {
290 if (EQ(symbol, Qand_rest)) {
293 SPECBIND_FAST_UNSAFE(symbol,
297 } else if (EQ(symbol, Qand_optional))
299 else if (i == nargs && !optional)
300 goto wrong_number_of_arguments;
302 SPECBIND_FAST_UNSAFE(symbol,
304 nargs ? args[i++] : Qnil);
309 goto wrong_number_of_arguments;
315 execute_optimized_program((Opbyte *)
316 XOPAQUE_DATA(f->instructions),
318 XVECTOR_DATA(f->constants));
320 /* The attempt to optimize this by only unbinding variables failed
321 because using buffer-local variables as function parameters
322 leads to specpdl_ptr->func != 0 */
323 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */
324 UNBIND_TO_GCPRO(speccount, value);
328 wrong_number_of_arguments:
329 /* The actual printed compiled_function object is incomprehensible.
330 Check the backtrace to see if we can get a more meaningful symbol. */
331 if (EQ(fun, indirect_function(*backtrace_list->function, 0)))
332 fun = *backtrace_list->function;
333 return Fsignal(Qwrong_number_of_arguments, list2(fun, make_int(nargs)));
336 /* Read next uint8 from the instruction stream. */
337 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
339 /* Read next uint16 from the instruction stream. */
340 #define READ_UINT_2 \
342 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \
343 ((unsigned int) (unsigned char) program_ptr[-2])))
345 /* Read next int8 from the instruction stream. */
346 #define READ_INT_1 ((int) (signed char) *program_ptr++)
348 /* Read next int16 from the instruction stream. */
351 (((int) ( signed char) program_ptr[-1]) * 256 + \
352 ((int) (unsigned char) program_ptr[-2])))
354 /* Read next int8 from instruction stream; don't advance program_pointer */
355 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
357 /* Read next int16 from instruction stream; don't advance program_pointer */
359 ((((int) ( signed char) program_ptr[1]) * 256) | \
360 ((int) (unsigned char) program_ptr[0]))
362 /* Do relative jumps from the current location.
363 We only do a QUIT if we jump backwards, for efficiency.
364 No infloops without backward jumps! */
365 #define JUMP_RELATIVE(jump) do { \
366 int JR_jump = (jump); \
367 if (JR_jump < 0) QUIT; \
368 program_ptr += JR_jump; \
371 #define JUMP JUMP_RELATIVE (PEEK_INT_2)
372 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
374 #define JUMP_NEXT ((void) (program_ptr += 2))
375 #define JUMPR_NEXT ((void) (program_ptr += 1))
377 /* Push x onto the execution stack. */
378 #define PUSH(x) (*++stack_ptr = (x))
380 /* Pop a value off the execution stack. */
381 #define POP (*stack_ptr--)
383 /* Discard n values from the execution stack. */
384 #define DISCARD(n) (stack_ptr -= (n))
386 /* Get the value which is at the top of the execution stack,
388 #define TOP (*stack_ptr)
390 /* See comment before the big switch in execute_optimized_program(). */
391 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
394 #define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg)
397 /* The actual interpreter for byte code.
398 This function has been seriously optimized for performance.
399 Don't change the constructs unless you are willing to do
400 real benchmarking and profiling work -- martin */
403 execute_optimized_program(const Opbyte *program,
404 int stack_depth, Lisp_Object *constants_data)
406 /* This function can GC */
407 REGISTER const Opbyte *program_ptr = program;
408 /* C99 here we come */
409 Lisp_Object stack_beg[stack_depth + 1];
410 REGISTER Lisp_Object *stack_ptr = stack_beg;
411 int speccount = specpdl_depth();
414 #ifdef BYTE_CODE_METER
415 Opcode this_opcode = 0;
419 #ifdef ERROR_CHECK_BYTE_CODE
420 Lisp_Object *stack_end = stack_beg + stack_depth;
423 /* We used to GCPRO the whole interpreter stack before entering this while
424 loop (21.5.14 and before), but that interferes with collection of weakly
425 referenced objects. Although strictly speaking there's no promise that
426 weak references will disappear by any given point in time, they should
427 be collected at the first opportunity. Waiting until exit from the
428 function caused test failures because "stale" objects "above" the top of
429 the stack were still GCPROed, and they were not getting collected until
430 after exit from the (byte-compiled) test!
432 Now the idea is to dynamically adjust the array of GCPROed objects to
433 include only the "active" region of the stack.
435 We use the "GCPRO1 the array base and set the nvars member" method. It
436 would be slightly inefficient but correct to use GCPRO1_ARRAY here. It
437 would just redundantly set nvars.
438 #### Maybe it would be clearer to use GCPRO1_ARRAY and do GCPRO_STACK
441 GCPRO_STACK is something of a misnomer, because it suggests that a
442 struct gcpro is initialized each time. This is false; only the nvars
443 member of a single struct gcpro is being adjusted. This works because
444 each time a new object is assigned to a stack location, the old object
445 loses its reference and is effectively UNGCPROed, and the new object is
446 automatically GCPROed as long as nvars is correct. Only when we
447 return from the interpreter do we need to finalize the struct gcpro
448 itself, and that's done at case Breturn.
450 GCPRO1 (stack_ptr[1]);
453 REGISTER Opcode opcode = READ_UINT_1;
455 /* Get nvars right before maybe signaling. */
457 #ifdef ERROR_CHECK_BYTE_CODE
458 if (stack_ptr > stack_end)
459 invalid_byte_code_error("byte code stack overflow");
460 if (stack_ptr < stack_beg)
461 invalid_byte_code_error("byte code stack underflow");
462 check_opcode(opcode);
465 #ifdef BYTE_CODE_METER
466 prev_opcode = this_opcode;
467 this_opcode = opcode;
468 meter_code(prev_opcode, this_opcode);
471 switch ((unsigned int)opcode) {
475 if (opcode >= Bconstant)
476 PUSH(constants_data[opcode - Bconstant]);
478 stack_ptr = execute_rare_opcode(
479 stack_ptr, program_ptr, opcode);
488 n = opcode - Bvarref;
494 n = READ_UINT_1; /* most common */
497 Lisp_Object symbol = constants_data[n];
498 Lisp_Object value = XSYMBOL(symbol)->value;
499 if (SYMBOL_VALUE_MAGIC_P(value))
500 value = Fsymbol_value(symbol);
511 n = opcode - Bvarset;
517 n = READ_UINT_1; /* most common */
520 Lisp_Object symbol = constants_data[n];
521 Lisp_Symbol *symbol_ptr = XSYMBOL(symbol);
522 Lisp_Object old_value = symbol_ptr->value;
523 Lisp_Object new_value = POP;
524 if (!SYMBOL_VALUE_MAGIC_P(old_value)
525 || UNBOUNDP(old_value))
526 symbol_ptr->value = new_value;
528 Fset(symbol, new_value);
538 n = opcode - Bvarbind;
544 n = READ_UINT_1; /* most common */
547 Lisp_Object symbol = constants_data[n];
548 Lisp_Symbol *symbol_ptr = XSYMBOL(symbol);
549 Lisp_Object old_value = symbol_ptr->value;
550 Lisp_Object new_value = POP;
551 if (!SYMBOL_VALUE_MAGIC_P(old_value)
552 || UNBOUNDP(old_value)) {
553 specpdl_ptr->symbol = symbol;
554 specpdl_ptr->old_value = old_value;
555 specpdl_ptr->func = 0;
557 specpdl_depth_counter++;
559 symbol_ptr->value = new_value;
561 #ifdef ERROR_CHECK_CATCH
562 check_specbind_stack_sanity ();
565 specbind_magic(symbol, new_value);
578 n = (opcode < Bcall + 6 ? opcode - Bcall :
579 opcode == Bcall + 6 ? READ_UINT_1 : READ_UINT_2);
581 #ifdef BYTE_CODE_METER
582 if (byte_metering_on && SYMBOLP(TOP)) {
584 Fget(TOP, Qbyte_code_meter, Qnil);
586 Fput(TOP, Qbyte_code_meter,
587 make_int(XINT(val) + 1));
590 TOP = Ffuncall(n + 1, &TOP);
601 UNBIND_TO(specpdl_depth() -
602 (opcode < Bunbind + 6 ? opcode - Bunbind :
604 Bunbind + 6 ? READ_UINT_1 : READ_UINT_2));
625 case Bgotoifnilelsepop:
634 case Bgotoifnonnilelsepop:
661 case BRgotoifnilelsepop:
670 case BRgotoifnonnilelsepop:
681 #ifdef ERROR_CHECK_BYTE_CODE
682 /* Binds and unbinds are supposed to be compiled balanced. */
683 if (specpdl_depth() != speccount)
684 invalid_byte_code_error
685 ("unbalanced specbinding stack");
695 Lisp_Object arg = TOP;
701 PUSH(constants_data[READ_UINT_2]);
705 TOP = CONSP(TOP) ? XCAR(TOP) : Fcar(TOP);
709 TOP = CONSP(TOP) ? XCDR(TOP) : Fcdr(TOP);
713 /* To unbind back to the beginning of this frame. Not
714 used yet, but will be needed for tail-recursion
716 unbind_to(speccount, Qnil);
720 Lisp_Object arg = POP;
721 TOP = Fcar(Fnthcdr(TOP, arg));
726 TOP = SYMBOLP(TOP) ? Qt : Qnil;
730 TOP = CONSP(TOP) ? Qt : Qnil;
734 TOP = STRINGP(TOP) ? Qt : Qnil;
738 TOP = LISTP(TOP) ? Qt : Qnil;
742 TOP = NUMBERP(TOP) ? Qt : Qnil;
746 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
747 TOP = INTEGERP(TOP) ? Qt : Qnil;
749 TOP = INTP(TOP) ? Qt : Qnil;
754 Lisp_Object arg = POP;
755 TOP = EQ_WITH_EBOLA_NOTICE(TOP, arg) ? Qt : Qnil;
760 TOP = NILP(TOP) ? Qt : Qnil;
764 Lisp_Object arg = POP;
765 TOP = Fcons(TOP, arg);
770 TOP = Fcons(TOP, Qnil);
781 n = opcode - (Blist1 - 1);
784 Lisp_Object list = Qnil;
786 list = Fcons(TOP, list);
798 n = opcode - (Bconcat2 - 2);
806 TOP = Fconcat(n, &TOP);
814 Lisp_Object arg2 = POP;
815 Lisp_Object arg1 = POP;
816 TOP = Faset(TOP, arg1, arg2);
821 TOP = Fsymbol_value(TOP);
824 case Bsymbol_function:
825 TOP = Fsymbol_function(TOP);
829 Lisp_Object arg = POP;
830 TOP = Fget(TOP, arg, Qnil);
843 Lisp_Object arg = POP;
844 if (ent_binrel(ASE_BINARY_REL_EQUALP, TOP, arg))
852 Lisp_Object arg = POP;
853 if (ent_binrel(ASE_BINARY_REL_GREATERP, TOP, arg))
861 Lisp_Object arg = POP;
862 if (ent_binrel(ASE_BINARY_REL_LESSP, TOP, arg))
870 Lisp_Object arg = POP;
871 if (ent_binrel2(ASE_BINARY_REL_LESSP,
872 ASE_BINARY_REL_EQUALP, TOP, arg))
880 Lisp_Object arg = POP;
881 if (ent_binrel2(ASE_BINARY_REL_GREATERP,
882 ASE_BINARY_REL_EQUALP, TOP, arg))
890 TOP = ent_unop_neg(TOP);
895 TOP = bytecode_nconc2(&TOP);
899 Lisp_Object arg = POP;
900 TOP = ent_binop(ASE_BINARY_OP_SUM, TOP, arg);
904 Lisp_Object arg = POP;
905 TOP = ent_binop(ASE_BINARY_OP_DIFF, TOP, arg);
909 Lisp_Object arg = POP;
910 TOP = ent_binop(ASE_BINARY_OP_PROD, TOP, arg);
914 Lisp_Object arg = POP;
915 TOP = ent_binop(ASE_BINARY_OP_DIV, TOP, arg);
919 Lisp_Object arg = POP;
920 if (!ent_binrel(ASE_BINARY_REL_GREATERP, TOP, arg))
925 Lisp_Object arg = POP;
926 if (!ent_binrel(ASE_BINARY_REL_LESSP, TOP, arg))
932 PUSH(make_int(BUF_PT(current_buffer)));
936 TOP = Finsert(1, &TOP);
942 TOP = Finsert(n, &TOP);
946 Lisp_Object arg = POP;
947 TOP = Faref(TOP, arg);
952 Lisp_Object arg = POP;
953 TOP = Fmemq(TOP, arg);
958 Lisp_Object arg = POP;
959 TOP = Fset(TOP, arg);
964 Lisp_Object arg = POP;
965 TOP = Fequal(TOP, arg);
970 Lisp_Object arg = POP;
971 TOP = Fnthcdr(TOP, arg);
976 Lisp_Object arg = POP;
977 TOP = Felt(TOP, arg);
982 Lisp_Object arg = POP;
983 TOP = Fmember(TOP, arg);
988 TOP = Fgoto_char(TOP, Qnil);
991 case Bcurrent_buffer: {
993 XSETBUFFER(buffer, current_buffer);
999 TOP = Fset_buffer(TOP);
1003 PUSH(make_int(BUF_ZV(current_buffer)));
1007 PUSH(make_int(BUF_BEGV(current_buffer)));
1010 case Bskip_chars_forward: {
1011 Lisp_Object arg = POP;
1012 TOP = Fskip_chars_forward(TOP, arg, Qnil);
1017 Lisp_Object arg = POP;
1018 TOP = Fassq(TOP, arg);
1023 Lisp_Object arg = POP;
1024 TOP = Fsetcar(TOP, arg);
1029 Lisp_Object arg = POP;
1030 TOP = Fsetcdr(TOP, arg);
1035 TOP = bytecode_nreverse(TOP);
1039 TOP = CONSP(TOP) ? XCAR(TOP) : Qnil;
1043 TOP = CONSP(TOP) ? XCDR(TOP) : Qnil;
1047 Lisp_Object op = TOP;
1048 Lisp_Object orig_fun, fun;
1051 orig_fun = fun = XCAR(op);
1052 SXE_SET_UNUSED(orig_fun);
1055 if (SYMBOLP (fun) && !EQ(fun, Qunbound) &&
1056 (fun = XSYMBOL(fun)->function, SYMBOLP(fun)))
1057 fun = indirect_function(fun, 1);
1058 if (SUBRP(fun) && XSUBR(fun)->max_args == UNEVALLED) {
1059 Lisp_Object(*subr)(Lisp_Object) =
1060 (Lisp_Object(*)(Lisp_Object))
1061 subr_function(XSUBR(fun));
1064 fprintf(stderr, "Uh-oh!\nSuicide?\n");
1066 fprintf(stderr, "YESSSSSS!\n");
1069 fprintf(stderr, "tomorrow maybe\n");
1077 /* It makes a worthwhile performance difference (5%) to shunt
1078 lesser-used opcodes off to a subroutine, to keep the switch in
1079 execute_optimized_program small. If you REALLY care about
1080 performance, you want to keep your heavily executed code away from
1081 rarely executed code, to minimize cache misses.
1083 Don't make this function static, since then the compiler might inline it.
1085 How about __attribute__((noinline)) then? -hrop */
1087 execute_rare_opcode(Lisp_Object *stack_ptr,
1088 const Opbyte *program_ptr, Opcode opcode)
1090 switch ((unsigned int)opcode) {
1092 case Bsave_excursion:
1093 record_unwind_protect(save_excursion_restore,
1094 save_excursion_save());
1097 case Bsave_window_excursion: {
1098 int count = specpdl_depth();
1099 record_unwind_protect(save_window_excursion_unwind,
1100 Fcurrent_window_configuration
1103 unbind_to(count, Qnil);
1107 case Bsave_restriction:
1108 record_unwind_protect(save_restriction_restore,
1109 save_restriction_save());
1113 Lisp_Object arg = POP;
1114 TOP = internal_catch(TOP, Feval, arg, 0);
1118 case Bskip_chars_backward: {
1119 Lisp_Object arg = POP;
1120 TOP = Fskip_chars_backward(TOP, arg, Qnil);
1124 case Bunwind_protect:
1125 record_unwind_protect(Fprogn, POP);
1128 case Bcondition_case: {
1129 Lisp_Object arg2 = POP; /* handlers */
1130 Lisp_Object arg1 = POP; /* bodyform */
1131 TOP = condition_case_3(arg1, TOP, arg2);
1136 Lisp_Object arg2 = POP;
1137 Lisp_Object arg1 = POP;
1138 TOP = Fset_marker(TOP, arg1, arg2);
1143 Lisp_Object arg = POP;
1144 TOP = ent_binop(ASE_BINARY_OP_REM, TOP, arg);
1148 case Bmatch_beginning:
1149 TOP = Fmatch_beginning(TOP);
1153 TOP = Fmatch_end(TOP);
1157 TOP = Fupcase(TOP, Qnil);
1161 TOP = Fdowncase(TOP, Qnil);
1165 Lisp_Object arg = POP;
1166 TOP = Ffset(TOP, arg);
1170 case Bstring_equal: {
1171 Lisp_Object arg = POP;
1172 TOP = Fstring_equal(TOP, arg);
1176 case Bstring_lessp: {
1177 Lisp_Object arg = POP;
1178 TOP = Fstring_lessp(TOP, arg);
1183 Lisp_Object arg2 = POP;
1184 Lisp_Object arg1 = POP;
1185 TOP = Fsubstring(TOP, arg1, arg2);
1189 case Bcurrent_column:
1190 PUSH(make_int(current_column(current_buffer)));
1194 TOP = Fchar_after(TOP, Qnil);
1198 TOP = Findent_to(TOP, Qnil, Qnil);
1205 case Bfollowing_char:
1206 PUSH(Ffollowing_char(Qnil));
1209 case Bpreceding_char:
1210 PUSH(Fpreceding_char(Qnil));
1229 case Bsave_current_buffer:
1230 record_unwind_protect(save_current_buffer_restore,
1234 case Binteractive_p:
1235 PUSH(Finteractive_p());
1239 TOP = Fforward_char(TOP, Qnil);
1243 TOP = Fforward_word(TOP, Qnil);
1247 TOP = Fforward_line(TOP, Qnil);
1251 TOP = Fchar_syntax(TOP, Qnil);
1254 case Bbuffer_substring: {
1255 Lisp_Object arg = POP;
1256 TOP = Fbuffer_substring(TOP, arg, Qnil);
1260 case Bdelete_region: {
1261 Lisp_Object arg = POP;
1262 TOP = Fdelete_region(TOP, arg, Qnil);
1266 case Bnarrow_to_region: {
1267 Lisp_Object arg = POP;
1268 TOP = Fnarrow_to_region(TOP, arg, Qnil);
1273 TOP = Fend_of_line(TOP, Qnil);
1276 case Btemp_output_buffer_setup:
1277 temp_output_buffer_setup(TOP);
1278 TOP = Vstandard_output;
1281 case Btemp_output_buffer_show: {
1282 Lisp_Object arg = POP;
1283 temp_output_buffer_show(TOP, Qnil);
1286 /* pop binding of standard-output */
1287 unbind_to(specpdl_depth() - 1, Qnil);
1293 Lisp_Object arg = POP;
1294 TOP = HACKEQ_UNSAFE(TOP, arg) ? Qt : Qnil;
1299 Lisp_Object arg = POP;
1300 TOP = Fold_memq(TOP, arg);
1305 Lisp_Object arg = POP;
1306 TOP = Fold_equal(TOP, arg);
1311 Lisp_Object arg = POP;
1312 TOP = Fold_member(TOP, arg);
1317 Lisp_Object arg = POP;
1318 TOP = Fold_assq(TOP, arg);
1330 static void invalid_byte_code_error(char *error_message, ...)
1334 int maxsz = strlen(error_message) + 128;
1335 char *buf = alloca_array(char, maxsz);
1337 int sz=snprintf(buf, maxsz, "%s", error_message);
1338 assert(sz>=0 && sz<maxsz);
1339 va_start(args, error_message);
1340 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(buf), Qnil, -1,
1344 signal_error(Qinvalid_byte_code, list1(obj));
1347 /* Check for valid opcodes. Change this when adding new opcodes. */
1348 static void check_opcode(Opcode opcode)
1350 if ((opcode < Bvarref) ||
1352 (opcode > BLAST_BEFORE_THREE_O_O && opcode < Bconstant))
1353 invalid_byte_code_error
1354 ("invalid opcode %d in instruction stream", opcode);
1357 /* Check that IDX is a valid offset into the `constants' vector */
1358 static void check_constants_index(int idx, Lisp_Object constants)
1360 if (idx < 0 || idx >= XVECTOR_LENGTH(constants))
1361 invalid_byte_code_error
1362 ("reference %d to constants array out of range 0, %d",
1363 idx, XVECTOR_LENGTH(constants) - 1);
1366 /* Get next character from Lisp instructions string. */
1367 #define READ_INSTRUCTION_CHAR(lvalue) do { \
1368 (lvalue) = charptr_emchar (ptr); \
1369 INC_CHARPTR (ptr); \
1370 *icounts_ptr++ = program_ptr - program; \
1371 if (lvalue > UCHAR_MAX) \
1372 invalid_byte_code_error \
1373 ("Invalid character %c in byte code string"); \
1376 /* Get opcode from Lisp instructions string. */
1377 #define READ_OPCODE do { \
1379 READ_INSTRUCTION_CHAR (c); \
1380 opcode = (Opcode) c; \
1383 /* Get next operand, a uint8, from Lisp instructions string. */
1384 #define READ_OPERAND_1 do { \
1385 READ_INSTRUCTION_CHAR (arg); \
1389 /* Get next operand, a uint16, from Lisp instructions string. */
1390 #define READ_OPERAND_2 do { \
1391 unsigned int arg1, arg2; \
1392 READ_INSTRUCTION_CHAR (arg1); \
1393 READ_INSTRUCTION_CHAR (arg2); \
1394 arg = arg1 + (arg2 << 8); \
1398 /* Write 1 byte to PTR, incrementing PTR */
1399 #define WRITE_INT8(value, ptr) do { \
1400 *((ptr)++) = (value); \
1403 /* Write 2 bytes to PTR, incrementing PTR */
1404 #define WRITE_INT16(value, ptr) do { \
1405 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \
1406 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \
1409 /* We've changed our minds about the opcode we've already written. */
1410 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
1412 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
1413 #define WRITE_NARGS(base_opcode) do { \
1416 REWRITE_OPCODE (base_opcode + arg); \
1418 else if (arg <= UCHAR_MAX) \
1420 REWRITE_OPCODE (base_opcode + 6); \
1421 WRITE_INT8 (arg, program_ptr); \
1425 REWRITE_OPCODE (base_opcode + 7); \
1426 WRITE_INT16 (arg, program_ptr); \
1430 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
1431 #define WRITE_CONSTANT do { \
1432 check_constants_index(arg, constants); \
1433 if (arg <= UCHAR_MAX - Bconstant) \
1435 REWRITE_OPCODE (Bconstant + arg); \
1439 REWRITE_OPCODE (Bconstant2); \
1440 WRITE_INT16 (arg, program_ptr); \
1444 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
1446 /* Compile byte code instructions into free space provided by caller, with
1447 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
1448 Returns length of compiled code. */
1449 static void optimize_byte_code(
1451 Lisp_Object instructions,
1452 Lisp_Object constants,
1454 Opbyte * const program,
1455 int *const program_length,
1456 int *const varbind_count)
1458 size_t instructions_length = XSTRING_LENGTH(instructions);
1459 size_t comfy_size = 2 * instructions_length;
1461 int *const icounts = alloca_array(int, comfy_size);
1462 int *icounts_ptr = icounts;
1464 /* We maintain a table of jumps in the source code. */
1469 struct jump *const jumps = alloca_array(struct jump, comfy_size);
1470 struct jump *jumps_ptr = jumps;
1472 Opbyte *program_ptr = program;
1474 /* const means constant! */
1475 Bufbyte *ptr = XSTRING_DATA(instructions);
1476 const Bufbyte *const end = ptr + instructions_length;
1487 switch ((unsigned int)opcode) {
1502 arg = opcode - Bvarref;
1504 check_constants_index(arg, constants);
1505 val = XVECTOR_DATA(constants)[arg];
1507 invalid_byte_code_error
1508 ("variable reference to non-symbol %S",
1510 if (EQ(val, Qnil) || EQ(val, Qt)
1511 || (SYMBOL_IS_KEYWORD(val)))
1512 invalid_byte_code_error
1513 ("variable reference to constant symbol %s",
1514 string_data(XSYMBOL(val)->name));
1515 WRITE_NARGS(Bvarref);
1530 arg = opcode - Bvarset;
1532 check_constants_index(arg, constants);
1533 val = XVECTOR_DATA(constants)[arg];
1535 invalid_byte_code_error
1536 ("attempt to set non-symbol %S", val);
1537 if (EQ(val, Qnil) || EQ(val, Qt))
1538 invalid_byte_code_error
1539 ("attempt to set constant symbol %s",
1540 string_data(XSYMBOL(val)->name));
1541 /* Ignore assignments to keywords by converting to Bdiscard.
1542 For backward compatibility only - we'd like to make this an error. */
1543 if (SYMBOL_IS_KEYWORD(val))
1544 REWRITE_OPCODE(Bdiscard);
1546 WRITE_NARGS(Bvarset);
1561 arg = opcode - Bvarbind;
1564 check_constants_index(arg, constants);
1565 val = XVECTOR_DATA(constants)[arg];
1567 invalid_byte_code_error
1568 ("attempt to let-bind non-symbol %S", val);
1569 if (EQ(val, Qnil) || EQ(val, Qt)
1570 || (SYMBOL_IS_KEYWORD(val)))
1571 invalid_byte_code_error
1572 ("attempt to let-bind constant symbol %s",
1573 string_data(XSYMBOL(val)->name));
1574 WRITE_NARGS(Bvarbind);
1589 arg = opcode - Bcall;
1606 arg = opcode - Bunbind;
1608 WRITE_NARGS(Bunbind);
1614 case Bgotoifnilelsepop:
1615 case Bgotoifnonnilelsepop:
1617 /* Make program_ptr-relative */
1618 arg += icounts - (icounts_ptr - argsize);
1623 case BRgotoifnonnil:
1624 case BRgotoifnilelsepop:
1625 case BRgotoifnonnilelsepop:
1627 /* Make program_ptr-relative */
1630 /* Record program-relative goto addresses in `jumps' table */
1631 jumps_ptr->from = icounts_ptr - icounts - argsize;
1632 jumps_ptr->to = jumps_ptr->from + arg;
1634 if (arg >= -1 && arg <= argsize)
1635 invalid_byte_code_error
1636 ("goto instruction is its own target");
1637 if (arg <= SCHAR_MIN || arg > SCHAR_MAX) {
1639 REWRITE_OPCODE(opcode + Bgoto - BRgoto);
1640 WRITE_INT16(arg, program_ptr);
1643 REWRITE_OPCODE(opcode + BRgoto - Bgoto);
1644 WRITE_INT8(arg, program_ptr);
1657 WRITE_INT8(arg, program_ptr);
1661 if (opcode < Bconstant)
1662 check_opcode(opcode);
1664 arg = opcode - Bconstant;
1671 /* Fix up jumps table to refer to NEW offsets. */
1672 for (struct jump *j = jumps; j < jumps_ptr; j++) {
1673 #ifdef ERROR_CHECK_BYTE_CODE
1674 assert(j->from < icounts_ptr - icounts);
1675 assert(j->to < icounts_ptr - icounts);
1677 j->from = icounts[j->from];
1678 j->to = icounts[j->to];
1679 #ifdef ERROR_CHECK_BYTE_CODE
1680 assert(j->from < program_ptr - program);
1681 assert(j->to < program_ptr - program);
1682 check_opcode((Opcode) (program[j->from - 1]));
1684 check_opcode((Opcode) (program[j->to]));
1687 /* Fixup jumps in byte-code until no more fixups needed */
1688 for (bool more_fixups_needed = true; more_fixups_needed; ) {
1691 /* assume we don't need more hiccups */
1692 more_fixups_needed = false;
1693 for (j = jumps; j < jumps_ptr; j++) {
1696 int jump = to - from;
1697 Opbyte *p = program + from;
1698 Opcode opcode = (Opcode)p[-1];
1700 if (!more_fixups_needed) {
1701 check_opcode((Opcode) p[jump]);
1703 assert(to >= 0 && program + to < program_ptr);
1705 switch ((unsigned int)opcode) {
1709 case Bgotoifnilelsepop:
1710 case Bgotoifnonnilelsepop:
1711 WRITE_INT16(jump, p);
1716 case BRgotoifnonnil:
1717 case BRgotoifnilelsepop:
1718 case BRgotoifnonnilelsepop:
1719 if (jump > SCHAR_MIN && jump <= SCHAR_MAX) {
1720 WRITE_INT8(jump, p);
1725 for (jj = jumps; jj < jumps_ptr; jj++) {
1727 program_ptr - program);
1729 program_ptr - program);
1730 if (jj->from > from) {
1733 if (jj->to > from) {
1737 p[-1] += Bgoto - BRgoto;
1738 more_fixups_needed = true;
1739 memmove(p + 1, p, program_ptr++ - p);
1740 WRITE_INT16(jump, p);
1751 /* *program_ptr++ = 0; */
1752 *program_length = program_ptr - program;
1755 /* Optimize the byte code and store the optimized program, only
1756 understood by bytecode.c, in an opaque object in the
1757 instructions slot of the Compiled_Function object. */
1758 void optimize_compiled_function(Lisp_Object compiled_function)
1760 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(compiled_function);
1765 /* If we have not actually read the bytecode string
1766 and constants vector yet, fetch them from the file. */
1767 if (CONSP(f->instructions))
1768 Ffetch_bytecode(compiled_function);
1770 if (STRINGP(f->instructions)) {
1771 /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1772 which would be slightly more `proper' */
1774 alloca_array(Opbyte,
1775 1 + 2 * XSTRING_LENGTH(f->instructions));
1776 optimize_byte_code(f->instructions, f->constants, program,
1777 &program_length, &varbind_count);
1778 f->specpdl_depth = XINT(Flength(f->arglist)) + varbind_count;
1780 make_opaque(program, program_length * sizeof(Opbyte));
1783 assert(OPAQUEP(f->instructions));
1786 /************************************************************************/
1787 /* The compiled-function object type */
1788 /************************************************************************/
1790 print_compiled_function(Lisp_Object obj, Lisp_Object printcharfun,
1793 /* This function can GC */
1794 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(obj); /* GC doesn't relocate */
1795 int docp = f->flags.documentationp;
1796 int intp = f->flags.interactivep;
1797 struct gcpro gcpro1, gcpro2;
1798 GCPRO2(obj, printcharfun);
1800 write_c_string(print_readably ? "#[" : "#<compiled-function ",
1802 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1803 if (!print_readably) {
1804 Lisp_Object ann = compiled_function_annotation(f);
1806 write_c_string("(from ", printcharfun);
1807 print_internal(ann, printcharfun, 1);
1808 write_c_string(") ", printcharfun);
1811 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1812 /* COMPILED_ARGLIST = 0 */
1813 print_internal(compiled_function_arglist(f), printcharfun, escapeflag);
1815 /* COMPILED_INSTRUCTIONS = 1 */
1816 write_c_string(" ", printcharfun);
1818 struct gcpro ngcpro1;
1819 Lisp_Object instructions = compiled_function_instructions(f);
1820 NGCPRO1(instructions);
1821 if (STRINGP(instructions) && !print_readably) {
1822 /* We don't usually want to see that junk in the bytecode. */
1823 write_fmt_str(printcharfun, "\"...(%ld)\"",
1824 (long)XSTRING_CHAR_LENGTH(instructions));
1826 print_internal(instructions, printcharfun, escapeflag);
1830 /* COMPILED_CONSTANTS = 2 */
1831 write_c_string(" ", printcharfun);
1832 print_internal(compiled_function_constants(f), printcharfun,
1835 /* COMPILED_STACK_DEPTH = 3 */
1836 write_fmt_str(printcharfun, " %d", compiled_function_stack_depth(f));
1838 /* COMPILED_DOC_STRING = 4 */
1840 write_c_string(" ", printcharfun);
1841 print_internal(compiled_function_documentation(f), printcharfun,
1845 /* COMPILED_INTERACTIVE = 5 */
1847 write_c_string(" ", printcharfun);
1848 print_internal(compiled_function_interactive(f), printcharfun,
1853 write_c_string(print_readably ? "]" : ">", printcharfun);
1856 static Lisp_Object mark_compiled_function(Lisp_Object obj)
1858 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(obj);
1860 mark_object(f->instructions);
1861 mark_object(f->arglist);
1862 mark_object(f->doc_and_interactive);
1863 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1864 mark_object(f->annotated);
1866 /* tail-recurse on constants */
1867 return f->constants;
1871 compiled_function_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
1873 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION(obj1);
1874 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION(obj2);
1875 return (f1->flags.documentationp == f2->flags.documentationp && f1->flags.interactivep == f2->flags.interactivep && f1->flags.domainp == f2->flags.domainp && /* I18N3 */
1876 internal_equal(compiled_function_instructions(f1),
1877 compiled_function_instructions(f2), depth + 1) &&
1878 internal_equal(f1->constants, f2->constants, depth + 1) &&
1879 internal_equal(f1->arglist, f2->arglist, depth + 1) &&
1880 internal_equal(f1->doc_and_interactive,
1881 f2->doc_and_interactive, depth + 1));
1884 static unsigned long compiled_function_hash(Lisp_Object obj, int depth)
1886 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(obj);
1887 return HASH3((f->flags.documentationp << 2) +
1888 (f->flags.interactivep << 1) +
1890 internal_hash(f->instructions, depth + 1),
1891 internal_hash(f->constants, depth + 1));
1894 static const struct lrecord_description compiled_function_description[] = {
1895 {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, instructions)},
1896 {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, constants)},
1897 {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, arglist)},
1898 {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, doc_and_interactive)},
1899 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1900 {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, annotated)},
1905 DEFINE_BASIC_LRECORD_IMPLEMENTATION("compiled-function", compiled_function,
1906 mark_compiled_function,
1907 print_compiled_function, 0,
1908 compiled_function_equal,
1909 compiled_function_hash,
1910 compiled_function_description,
1911 Lisp_Compiled_Function);
1913 DEFUN("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
1914 Return t if OBJECT is a byte-compiled function object.
1918 return COMPILED_FUNCTIONP(object) ? Qt : Qnil;
1921 /************************************************************************/
1922 /* compiled-function object accessor functions */
1923 /************************************************************************/
1925 Lisp_Object compiled_function_arglist(Lisp_Compiled_Function * f)
1930 Lisp_Object compiled_function_instructions(Lisp_Compiled_Function * f)
1932 if (!OPAQUEP(f->instructions))
1933 return f->instructions;
1936 /* Invert action performed by optimize_byte_code() */
1937 Lisp_Opaque *opaque = XOPAQUE(f->instructions);
1939 Bufbyte *const buffer =
1940 alloca_array(Bufbyte, OPAQUE_SIZE(opaque) * MAX_EMCHAR_LEN);
1941 Bufbyte *bp = buffer;
1943 const Opbyte *const program =
1944 (const Opbyte *)OPAQUE_DATA(opaque);
1945 const Opbyte *program_ptr = program;
1946 const Opbyte *const program_end =
1947 program_ptr + OPAQUE_SIZE(opaque);
1949 while (program_ptr < program_end) {
1950 Opcode opcode = (Opcode) READ_UINT_1;
1951 bp += set_charptr_emchar(bp, opcode);
1953 switch ((unsigned int)opcode) {
1960 bp += set_charptr_emchar(bp, READ_UINT_1);
1961 bp += set_charptr_emchar(bp, READ_UINT_1);
1972 bp += set_charptr_emchar(bp, READ_UINT_1);
1978 case Bgotoifnilelsepop:
1979 case Bgotoifnonnilelsepop:
1981 int jump = READ_INT_2;
1983 Opbyte *buf2p = buf2;
1984 /* Convert back to program-relative address */
1986 (program_ptr - 2 - program),
1988 bp += set_charptr_emchar(bp, buf2[0]);
1989 bp += set_charptr_emchar(bp, buf2[1]);
1995 case BRgotoifnonnil:
1996 case BRgotoifnilelsepop:
1997 case BRgotoifnonnilelsepop:
1998 bp += set_charptr_emchar(bp, READ_INT_1 + 127);
2005 return make_string(buffer, bp - buffer);
2009 Lisp_Object compiled_function_constants(Lisp_Compiled_Function * f)
2011 return f->constants;
2014 int compiled_function_stack_depth(Lisp_Compiled_Function * f)
2016 return f->stack_depth;
2019 /* The compiled_function->doc_and_interactive slot uses the minimal
2020 number of conses, based on compiled_function->flags; it may take
2021 any of the following forms:
2028 (interactive . domain)
2029 (doc . (interactive . domain))
2032 /* Caller must check flags.interactivep first */
2033 Lisp_Object compiled_function_interactive(Lisp_Compiled_Function * f)
2035 assert(f->flags.interactivep);
2036 if (f->flags.documentationp && f->flags.domainp)
2037 return XCAR(XCDR(f->doc_and_interactive));
2038 else if (f->flags.documentationp)
2039 return XCDR(f->doc_and_interactive);
2040 else if (f->flags.domainp)
2041 return XCAR(f->doc_and_interactive);
2043 return f->doc_and_interactive;
2046 /* Caller need not check flags.documentationp first */
2047 Lisp_Object compiled_function_documentation(Lisp_Compiled_Function * f)
2049 if (!f->flags.documentationp)
2051 else if (f->flags.interactivep && f->flags.domainp)
2052 return XCAR(f->doc_and_interactive);
2053 else if (f->flags.interactivep)
2054 return XCAR(f->doc_and_interactive);
2055 else if (f->flags.domainp)
2056 return XCAR(f->doc_and_interactive);
2058 return f->doc_and_interactive;
2061 /* Caller need not check flags.domainp first */
2062 Lisp_Object compiled_function_domain(Lisp_Compiled_Function * f)
2064 if (!f->flags.domainp)
2066 else if (f->flags.documentationp && f->flags.interactivep)
2067 return XCDR(XCDR(f->doc_and_interactive));
2068 else if (f->flags.documentationp)
2069 return XCDR(f->doc_and_interactive);
2070 else if (f->flags.interactivep)
2071 return XCDR(f->doc_and_interactive);
2073 return f->doc_and_interactive;
2076 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2078 Lisp_Object compiled_function_annotation(Lisp_Compiled_Function * f)
2080 return f->annotated;
2085 /* used only by Snarf-documentation; there must be doc already. */
2087 set_compiled_function_documentation(Lisp_Compiled_Function * f,
2088 Lisp_Object new_doc)
2090 assert(f->flags.documentationp);
2091 assert(INTP(new_doc) || STRINGP(new_doc));
2093 if (f->flags.interactivep && f->flags.domainp)
2094 XCAR(f->doc_and_interactive) = new_doc;
2095 else if (f->flags.interactivep)
2096 XCAR(f->doc_and_interactive) = new_doc;
2097 else if (f->flags.domainp)
2098 XCAR(f->doc_and_interactive) = new_doc;
2100 f->doc_and_interactive = new_doc;
2103 DEFUN("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2104 Return the argument list of the compiled-function object FUNCTION.
2108 CHECK_COMPILED_FUNCTION(function);
2109 return compiled_function_arglist(XCOMPILED_FUNCTION(function));
2112 DEFUN("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
2113 Return the byte-opcode string of the compiled-function object FUNCTION.
2117 CHECK_COMPILED_FUNCTION(function);
2118 return compiled_function_instructions(XCOMPILED_FUNCTION(function));
2121 DEFUN("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
2122 Return the constants vector of the compiled-function object FUNCTION.
2126 CHECK_COMPILED_FUNCTION(function);
2127 return compiled_function_constants(XCOMPILED_FUNCTION(function));
2130 DEFUN("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2131 Return the maximum stack depth of the compiled-function object FUNCTION.
2135 CHECK_COMPILED_FUNCTION(function);
2137 make_int(compiled_function_stack_depth
2138 (XCOMPILED_FUNCTION(function)));
2141 DEFUN("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
2142 Return the doc string of the compiled-function object FUNCTION, if available.
2143 Functions that had their doc strings snarfed into the DOC file will have
2144 an integer returned instead of a string.
2148 CHECK_COMPILED_FUNCTION(function);
2149 return compiled_function_documentation(XCOMPILED_FUNCTION(function));
2152 DEFUN("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2153 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2154 If non-nil, the return value will be a list whose first element is
2155 `interactive' and whose second element is the interactive spec.
2159 CHECK_COMPILED_FUNCTION(function);
2160 return XCOMPILED_FUNCTION(function)->flags.interactivep
2161 ? list2(Qinteractive,
2162 compiled_function_interactive(XCOMPILED_FUNCTION(function)))
2166 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2168 /* Remove the `xx' if you wish to restore this feature */
2169 xxDEFUN("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2170 Return the annotation of the compiled-function object FUNCTION, or nil.
2171 The annotation is a piece of information indicating where this
2172 compiled-function object came from. Generally this will be
2173 a symbol naming a function; or a string naming a file, if the
2174 compiled-function object was not defined in a function; or nil,
2175 if the compiled-function object was not created as a result of
2179 CHECK_COMPILED_FUNCTION(function);
2180 return compiled_function_annotation(XCOMPILED_FUNCTION(function));
2183 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2185 DEFUN("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
2186 Return the domain of the compiled-function object FUNCTION, or nil.
2187 This is only meaningful if I18N3 was enabled when emacs was compiled.
2191 CHECK_COMPILED_FUNCTION(function);
2192 return XCOMPILED_FUNCTION(function)->flags.domainp
2193 ? compiled_function_domain(XCOMPILED_FUNCTION(function))
2197 DEFUN("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
2198 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2202 Lisp_Compiled_Function *f;
2203 CHECK_COMPILED_FUNCTION(function);
2204 f = XCOMPILED_FUNCTION(function);
2206 if (OPAQUEP(f->instructions) || STRINGP(f->instructions))
2209 if (CONSP(f->instructions)) {
2210 Lisp_Object tem = read_doc_string(f->instructions);
2212 signal_simple_error("Invalid lazy-loaded byte code",
2214 /* v18 or v19 bytecode file. Need to Ebolify. */
2215 if (f->flags.ebolified && VECTORP(XCDR(tem)))
2216 ebolify_bytecode_constants(XCDR(tem));
2217 f->instructions = XCAR(tem);
2218 f->constants = XCDR(tem);
2222 return Qnil; /* not reached */
2225 DEFUN("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
2226 Convert compiled function FUNCTION into an optimized internal form.
2230 Lisp_Compiled_Function *f;
2231 CHECK_COMPILED_FUNCTION(function);
2232 f = XCOMPILED_FUNCTION(function);
2234 if (OPAQUEP(f->instructions)) /* Already optimized? */
2237 optimize_compiled_function(function);
2241 DEFUN("byte-code", Fbyte_code, 3, 3, 0, /*
2242 Function used internally in byte-compiled code.
2243 First argument INSTRUCTIONS is a string of byte code.
2244 Second argument CONSTANTS is a vector of constants.
2245 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2246 If STACK-DEPTH is incorrect, Emacs may crash.
2248 (instructions, constants, stack_depth))
2250 /* This function can GC */
2255 CHECK_STRING(instructions);
2256 CHECK_VECTOR(constants);
2257 CHECK_NATNUM(stack_depth);
2259 /* Optimize the `instructions' string, just like when executing a
2260 regular compiled function, but don't save it for later since this is
2261 likely to only be executed once. */
2262 program = alloca_array(Opbyte, 1 + 2 * XSTRING_LENGTH(instructions));
2263 optimize_byte_code(instructions, constants, program,
2264 &program_length, &varbind_count);
2265 SPECPDL_RESERVE(varbind_count);
2266 return execute_optimized_program(program,
2268 XVECTOR_DATA(constants));
2271 void syms_of_bytecode(void)
2273 INIT_LRECORD_IMPLEMENTATION(compiled_function);
2275 DEFERROR_STANDARD(Qinvalid_byte_code, Qinvalid_state);
2276 defsymbol(&Qbyte_code, "byte-code");
2277 defsymbol(&Qcompiled_functionp, "compiled-function-p");
2279 DEFSUBR(Fbyte_code);
2280 DEFSUBR(Ffetch_bytecode);
2281 DEFSUBR(Foptimize_compiled_function);
2283 DEFSUBR(Fcompiled_function_p);
2284 DEFSUBR(Fcompiled_function_instructions);
2285 DEFSUBR(Fcompiled_function_constants);
2286 DEFSUBR(Fcompiled_function_stack_depth);
2287 DEFSUBR(Fcompiled_function_arglist);
2288 DEFSUBR(Fcompiled_function_interactive);
2289 DEFSUBR(Fcompiled_function_doc_string);
2290 DEFSUBR(Fcompiled_function_domain);
2291 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2292 DEFSUBR(Fcompiled_function_annotation);
2295 #ifdef BYTE_CODE_METER
2296 defsymbol(&Qbyte_code_meter, "byte-code-meter");
2300 void vars_of_bytecode(void)
2302 #ifdef BYTE_CODE_METER
2304 DEFVAR_LISP("byte-code-meter", &Vbyte_code_meter /*
2305 A vector of vectors which holds a histogram of byte code usage.
2306 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2307 opcode CODE has been executed.
2308 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2309 indicates how many times the byte opcodes CODE1 and CODE2 have been
2310 executed in succession.
2312 DEFVAR_BOOL("byte-metering-on", &byte_metering_on /*
2313 If non-nil, keep profiling information on byte code usage.
2314 The variable `byte-code-meter' indicates how often each byte opcode is used.
2315 If a symbol has a property named `byte-code-meter' whose value is an
2316 integer, it is incremented each time that symbol's function is called.
2319 byte_metering_on = 0;
2320 Vbyte_code_meter = make_vector(256, Qzero);
2324 XVECTOR_DATA(Vbyte_code_meter)[i] =
2325 make_vector(256, Qzero);
2327 #endif /* BYTE_CODE_METER */