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"
57 EXFUN(Ffetch_bytecode, 1);
59 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
61 enum Opcode { /* Byte codes */
87 Bsymbol_function = 0113,
110 Beq = 0141, /* was Bmark,
111 but no longer generated as of v18 */
117 Bfollowing_char = 0147,
118 Bpreceding_char = 0150,
119 Bcurrent_column = 0151,
121 Bequal = 0153, /* was Bscan_buffer,
122 but no longer generated as of v18 */
127 Bcurrent_buffer = 0160,
129 Bsave_current_buffer = 0162, /* was Bread_char,
130 but no longer generated as of v19 */
131 Bmemq = 0163, /* was Bset_mark,
132 but no longer generated as of v18 */
133 Binteractive_p = 0164, /* Needed since interactive-p takes
135 Bforward_char = 0165,
136 Bforward_word = 0166,
137 Bskip_chars_forward = 0167,
138 Bskip_chars_backward = 0170,
139 Bforward_line = 0171,
141 Bbuffer_substring = 0173,
142 Bdelete_region = 0174,
143 Bnarrow_to_region = 0175,
150 Bgotoifnonnil = 0204,
151 Bgotoifnilelsepop = 0205,
152 Bgotoifnonnilelsepop = 0206,
157 Bsave_excursion = 0212,
158 Bsave_window_excursion = 0213,
159 Bsave_restriction = 0214,
162 Bunwind_protect = 0216,
163 Bcondition_case = 0217,
164 Btemp_output_buffer_setup = 0220,
165 Btemp_output_buffer_show = 0221,
170 Bmatch_beginning = 0224,
175 Bstring_equal = 0230,
176 Bstring_lessp = 0231,
195 BRgotoifnonnil = 0254,
196 BRgotoifnilelsepop = 0255,
197 BRgotoifnonnilelsepop = 0256,
202 Bmember = 0266, /* new in v20 */
203 Bassq = 0267, /* new in v20 */
205 Bcl_macro = 0270, /* only if modules/cl is there */
207 BLAST_BEFORE_THREE_O_O = Bcl_macro,
211 typedef enum Opcode Opcode;
212 typedef unsigned char Opbyte;
214 static void check_opcode(Opcode opcode);
215 static void invalid_byte_code_error(char *error_message, ...);
218 execute_rare_opcode(Lisp_Object *stk, const Opbyte *prg, Opcode opcode)
219 __attribute__((noinline));
221 static Lisp_Object execute_optimized_program(const Opbyte * program,
223 Lisp_Object * constants_data);
225 extern Lisp_Object Qand_rest, Qand_optional;
227 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
228 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
229 /* #define BYTE_CODE_METER */
231 #ifdef BYTE_CODE_METER
233 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
234 int byte_metering_on;
236 static void meter_code(Opcode prev_opcode, Opcode this_opcode)
238 if (byte_metering_on) {
240 XVECTOR_DATA(XVECTOR_DATA(Vbyte_code_meter)[this_opcode]);
241 p[0] = INT_PLUS1(p[0]);
243 p[prev_opcode] = INT_PLUS1(p[prev_opcode]);
247 #endif /* BYTE_CODE_METER */
249 static Lisp_Object bytecode_nreverse(Lisp_Object list)
251 REGISTER Lisp_Object prev = Qnil;
252 REGISTER Lisp_Object tail = list;
254 while (!NILP(tail)) {
255 REGISTER Lisp_Object next;
265 /* Apply compiled-function object FUN to the NARGS evaluated arguments
266 in ARGS, and return the result of evaluation. */
268 funcall_compiled_function(Lisp_Object fun, int nargs, Lisp_Object args[])
270 /* This function can GC */
271 int speccount = specpdl_depth();
273 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(fun);
276 if (!OPAQUEP(f->instructions))
277 /* Lazily munge the instructions into a more efficient form */
278 optimize_compiled_function(fun);
280 /* optimize_compiled_function() guaranteed that f->specpdl_depth is
281 the required space on the specbinding stack for binding the args
282 and local variables of fun. So just reserve it once. */
283 SPECPDL_RESERVE(f->specpdl_depth);
286 /* Fmake_byte_code() guaranteed that f->arglist is a valid list
287 containing only non-constant symbols. */
288 LIST_LOOP_3(symbol, f->arglist, tail) {
289 if (EQ(symbol, Qand_rest)) {
292 SPECBIND_FAST_UNSAFE(symbol,
296 } else if (EQ(symbol, Qand_optional))
298 else if (i == nargs && !optional)
299 goto wrong_number_of_arguments;
301 SPECBIND_FAST_UNSAFE(symbol,
303 nargs ? args[i++] : Qnil);
308 goto wrong_number_of_arguments;
314 execute_optimized_program((Opbyte *)
315 XOPAQUE_DATA(f->instructions),
317 XVECTOR_DATA(f->constants));
319 /* The attempt to optimize this by only unbinding variables failed
320 because using buffer-local variables as function parameters
321 leads to specpdl_ptr->func != 0 */
322 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */
323 UNBIND_TO_GCPRO(speccount, value);
327 wrong_number_of_arguments:
328 /* The actual printed compiled_function object is incomprehensible.
329 Check the backtrace to see if we can get a more meaningful symbol. */
330 if (EQ(fun, indirect_function(*backtrace_list->function, 0)))
331 fun = *backtrace_list->function;
332 return Fsignal(Qwrong_number_of_arguments, list2(fun, make_int(nargs)));
335 /* Read next uint8 from the instruction stream. */
336 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
338 /* Read next uint16 from the instruction stream. */
339 #define READ_UINT_2 \
341 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \
342 ((unsigned int) (unsigned char) program_ptr[-2])))
344 /* Read next int8 from the instruction stream. */
345 #define READ_INT_1 ((int) (signed char) *program_ptr++)
347 /* Read next int16 from the instruction stream. */
350 (((int) ( signed char) program_ptr[-1]) * 256 + \
351 ((int) (unsigned char) program_ptr[-2])))
353 /* Read next int8 from instruction stream; don't advance program_pointer */
354 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
356 /* Read next int16 from instruction stream; don't advance program_pointer */
358 ((((int) ( signed char) program_ptr[1]) * 256) | \
359 ((int) (unsigned char) program_ptr[0]))
361 /* Do relative jumps from the current location.
362 We only do a QUIT if we jump backwards, for efficiency.
363 No infloops without backward jumps! */
364 #define JUMP_RELATIVE(jump) do { \
365 int JR_jump = (jump); \
366 if (JR_jump < 0) QUIT; \
367 program_ptr += JR_jump; \
370 #define JUMP JUMP_RELATIVE (PEEK_INT_2)
371 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
373 #define JUMP_NEXT ((void) (program_ptr += 2))
374 #define JUMPR_NEXT ((void) (program_ptr += 1))
376 /* Push x onto the execution stack. */
377 #define PUSH(x) (*++stack_ptr = (x))
379 /* Pop a value off the execution stack. */
380 #define POP (*stack_ptr--)
382 /* Discard n values from the execution stack. */
383 #define DISCARD(n) (stack_ptr -= (n))
385 /* Get the value which is at the top of the execution stack,
387 #define TOP (*stack_ptr)
389 /* See comment before the big switch in execute_optimized_program(). */
390 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
393 #define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg)
396 /* The actual interpreter for byte code.
397 This function has been seriously optimized for performance.
398 Don't change the constructs unless you are willing to do
399 real benchmarking and profiling work -- martin */
402 execute_optimized_program(const Opbyte *program,
403 int stack_depth, Lisp_Object *constants_data)
405 /* This function can GC */
406 REGISTER const Opbyte *program_ptr = program;
407 /* C99 here we come */
408 Lisp_Object stack_beg[stack_depth + 1];
409 REGISTER Lisp_Object *stack_ptr = stack_beg;
410 int speccount = specpdl_depth();
413 #ifdef BYTE_CODE_METER
414 Opcode this_opcode = 0;
418 #ifdef ERROR_CHECK_BYTE_CODE
419 Lisp_Object *stack_end = stack_beg + stack_depth;
422 /* We used to GCPRO the whole interpreter stack before entering this while
423 loop (21.5.14 and before), but that interferes with collection of weakly
424 referenced objects. Although strictly speaking there's no promise that
425 weak references will disappear by any given point in time, they should
426 be collected at the first opportunity. Waiting until exit from the
427 function caused test failures because "stale" objects "above" the top of
428 the stack were still GCPROed, and they were not getting collected until
429 after exit from the (byte-compiled) test!
431 Now the idea is to dynamically adjust the array of GCPROed objects to
432 include only the "active" region of the stack.
434 We use the "GCPRO1 the array base and set the nvars member" method. It
435 would be slightly inefficient but correct to use GCPRO1_ARRAY here. It
436 would just redundantly set nvars.
437 #### Maybe it would be clearer to use GCPRO1_ARRAY and do GCPRO_STACK
440 GCPRO_STACK is something of a misnomer, because it suggests that a
441 struct gcpro is initialized each time. This is false; only the nvars
442 member of a single struct gcpro is being adjusted. This works because
443 each time a new object is assigned to a stack location, the old object
444 loses its reference and is effectively UNGCPROed, and the new object is
445 automatically GCPROed as long as nvars is correct. Only when we
446 return from the interpreter do we need to finalize the struct gcpro
447 itself, and that's done at case Breturn.
449 GCPRO1 (stack_ptr[1]);
452 REGISTER Opcode opcode = READ_UINT_1;
454 /* Get nvars right before maybe signaling. */
456 #ifdef ERROR_CHECK_BYTE_CODE
457 if (stack_ptr > stack_end)
458 invalid_byte_code_error("byte code stack overflow");
459 if (stack_ptr < stack_beg)
460 invalid_byte_code_error("byte code stack underflow");
461 check_opcode(opcode);
464 #ifdef BYTE_CODE_METER
465 prev_opcode = this_opcode;
466 this_opcode = opcode;
467 meter_code(prev_opcode, this_opcode);
470 switch ((unsigned int)opcode) {
474 if (opcode >= Bconstant)
475 PUSH(constants_data[opcode - Bconstant]);
477 stack_ptr = execute_rare_opcode(
478 stack_ptr, program_ptr, opcode);
487 n = opcode - Bvarref;
493 n = READ_UINT_1; /* most common */
496 Lisp_Object symbol = constants_data[n];
497 Lisp_Object value = XSYMBOL(symbol)->value;
498 if (SYMBOL_VALUE_MAGIC_P(value))
499 value = Fsymbol_value(symbol);
510 n = opcode - Bvarset;
516 n = READ_UINT_1; /* most common */
519 Lisp_Object symbol = constants_data[n];
520 Lisp_Symbol *symbol_ptr = XSYMBOL(symbol);
521 Lisp_Object old_value = symbol_ptr->value;
522 Lisp_Object new_value = POP;
523 if (!SYMBOL_VALUE_MAGIC_P(old_value)
524 || UNBOUNDP(old_value))
525 symbol_ptr->value = new_value;
527 Fset(symbol, new_value);
537 n = opcode - Bvarbind;
543 n = READ_UINT_1; /* most common */
546 Lisp_Object symbol = constants_data[n];
547 Lisp_Symbol *symbol_ptr = XSYMBOL(symbol);
548 Lisp_Object old_value = symbol_ptr->value;
549 Lisp_Object new_value = POP;
550 if (!SYMBOL_VALUE_MAGIC_P(old_value)
551 || UNBOUNDP(old_value)) {
552 specpdl_ptr->symbol = symbol;
553 specpdl_ptr->old_value = old_value;
554 specpdl_ptr->func = 0;
556 specpdl_depth_counter++;
558 symbol_ptr->value = new_value;
560 #ifdef ERROR_CHECK_CATCH
561 check_specbind_stack_sanity ();
564 specbind_magic(symbol, new_value);
577 n = (opcode < Bcall + 6 ? opcode - Bcall :
578 opcode == Bcall + 6 ? READ_UINT_1 : READ_UINT_2);
580 #ifdef BYTE_CODE_METER
581 if (byte_metering_on && SYMBOLP(TOP)) {
583 Fget(TOP, Qbyte_code_meter, Qnil);
585 Fput(TOP, Qbyte_code_meter,
586 make_int(XINT(val) + 1));
589 TOP = Ffuncall(n + 1, &TOP);
600 UNBIND_TO(specpdl_depth() -
601 (opcode < Bunbind + 6 ? opcode - Bunbind :
603 Bunbind + 6 ? READ_UINT_1 : READ_UINT_2));
624 case Bgotoifnilelsepop:
633 case Bgotoifnonnilelsepop:
660 case BRgotoifnilelsepop:
669 case BRgotoifnonnilelsepop:
680 #ifdef ERROR_CHECK_BYTE_CODE
681 /* Binds and unbinds are supposed to be compiled balanced. */
682 if (specpdl_depth() != speccount)
683 invalid_byte_code_error
684 ("unbalanced specbinding stack");
694 Lisp_Object arg = TOP;
700 PUSH(constants_data[READ_UINT_2]);
704 TOP = CONSP(TOP) ? XCAR(TOP) : Fcar(TOP);
708 TOP = CONSP(TOP) ? XCDR(TOP) : Fcdr(TOP);
712 /* To unbind back to the beginning of this frame. Not
713 used yet, but will be needed for tail-recursion
715 unbind_to(speccount, Qnil);
719 Lisp_Object arg = POP;
720 TOP = Fcar(Fnthcdr(TOP, arg));
725 TOP = SYMBOLP(TOP) ? Qt : Qnil;
729 TOP = CONSP(TOP) ? Qt : Qnil;
733 TOP = STRINGP(TOP) ? Qt : Qnil;
737 TOP = LISTP(TOP) ? Qt : Qnil;
741 TOP = NUMBERP(TOP) ? Qt : Qnil;
745 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
746 TOP = INTEGERP(TOP) ? Qt : Qnil;
748 TOP = INTP(TOP) ? Qt : Qnil;
753 Lisp_Object arg = POP;
754 TOP = EQ_WITH_EBOLA_NOTICE(TOP, arg) ? Qt : Qnil;
759 TOP = NILP(TOP) ? Qt : Qnil;
763 Lisp_Object arg = POP;
764 TOP = Fcons(TOP, arg);
769 TOP = Fcons(TOP, Qnil);
780 n = opcode - (Blist1 - 1);
783 Lisp_Object list = Qnil;
785 list = Fcons(TOP, list);
797 n = opcode - (Bconcat2 - 2);
805 TOP = Fconcat(n, &TOP);
813 Lisp_Object arg2 = POP;
814 Lisp_Object arg1 = POP;
815 TOP = Faset(TOP, arg1, arg2);
820 TOP = Fsymbol_value(TOP);
823 case Bsymbol_function:
824 TOP = Fsymbol_function(TOP);
828 Lisp_Object arg = POP;
829 TOP = Fget(TOP, arg, Qnil);
842 Lisp_Object arg = POP;
843 if (ent_binrel(ASE_BINARY_REL_EQUALP, TOP, arg))
851 Lisp_Object arg = POP;
852 if (ent_binrel(ASE_BINARY_REL_GREATERP, TOP, arg))
860 Lisp_Object arg = POP;
861 if (ent_binrel(ASE_BINARY_REL_LESSP, TOP, arg))
869 Lisp_Object arg = POP;
870 if (ent_binrel2(ASE_BINARY_REL_LESSP,
871 ASE_BINARY_REL_EQUALP, TOP, arg))
879 Lisp_Object arg = POP;
880 if (ent_binrel2(ASE_BINARY_REL_GREATERP,
881 ASE_BINARY_REL_EQUALP, TOP, arg))
889 TOP = ent_unop_neg(TOP);
894 TOP = bytecode_nconc2(&TOP);
898 Lisp_Object arg = POP;
899 TOP = ent_binop(ASE_BINARY_OP_SUM, TOP, arg);
903 Lisp_Object arg = POP;
904 TOP = ent_binop(ASE_BINARY_OP_DIFF, TOP, arg);
908 Lisp_Object arg = POP;
909 TOP = ent_binop(ASE_BINARY_OP_PROD, TOP, arg);
913 Lisp_Object arg = POP;
914 TOP = ent_binop(ASE_BINARY_OP_DIV, TOP, arg);
918 Lisp_Object arg = POP;
919 if (!ent_binrel(ASE_BINARY_REL_GREATERP, TOP, arg))
924 Lisp_Object arg = POP;
925 if (!ent_binrel(ASE_BINARY_REL_LESSP, TOP, arg))
931 PUSH(make_int(BUF_PT(current_buffer)));
935 TOP = Finsert(1, &TOP);
941 TOP = Finsert(n, &TOP);
945 Lisp_Object arg = POP;
946 TOP = Faref(TOP, arg);
951 Lisp_Object arg = POP;
952 TOP = Fmemq(TOP, arg);
957 Lisp_Object arg = POP;
958 TOP = Fset(TOP, arg);
963 Lisp_Object arg = POP;
964 TOP = Fequal(TOP, arg);
969 Lisp_Object arg = POP;
970 TOP = Fnthcdr(TOP, arg);
975 Lisp_Object arg = POP;
976 TOP = Felt(TOP, arg);
981 Lisp_Object arg = POP;
982 TOP = Fmember(TOP, arg);
987 TOP = Fgoto_char(TOP, Qnil);
990 case Bcurrent_buffer: {
992 XSETBUFFER(buffer, current_buffer);
998 TOP = Fset_buffer(TOP);
1002 PUSH(make_int(BUF_ZV(current_buffer)));
1006 PUSH(make_int(BUF_BEGV(current_buffer)));
1009 case Bskip_chars_forward: {
1010 Lisp_Object arg = POP;
1011 TOP = Fskip_chars_forward(TOP, arg, Qnil);
1016 Lisp_Object arg = POP;
1017 TOP = Fassq(TOP, arg);
1022 Lisp_Object arg = POP;
1023 TOP = Fsetcar(TOP, arg);
1028 Lisp_Object arg = POP;
1029 TOP = Fsetcdr(TOP, arg);
1034 TOP = bytecode_nreverse(TOP);
1038 TOP = CONSP(TOP) ? XCAR(TOP) : Qnil;
1042 TOP = CONSP(TOP) ? XCDR(TOP) : Qnil;
1046 Lisp_Object op = TOP;
1047 Lisp_Object orig_fun, fun;
1050 orig_fun = fun = XCAR(op);
1052 if (SYMBOLP (fun) && !EQ(fun, Qunbound) &&
1053 (fun = XSYMBOL(fun)->function, SYMBOLP(fun)))
1054 fun = indirect_function(fun, 1);
1055 if (SUBRP(fun) && XSUBR(fun)->max_args == UNEVALLED) {
1056 Lisp_Object(*subr)(Lisp_Object) =
1057 (Lisp_Object(*)(Lisp_Object))
1058 subr_function(XSUBR(fun));
1061 fprintf(stderr, "Uh-oh!\nSuicide?\n");
1063 fprintf(stderr, "YESSSSSS!\n");
1066 fprintf(stderr, "tomorrow maybe\n");
1074 /* It makes a worthwhile performance difference (5%) to shunt
1075 lesser-used opcodes off to a subroutine, to keep the switch in
1076 execute_optimized_program small. If you REALLY care about
1077 performance, you want to keep your heavily executed code away from
1078 rarely executed code, to minimize cache misses.
1080 Don't make this function static, since then the compiler might inline it.
1082 How about __attribute__((noinline)) then? -hrop */
1084 execute_rare_opcode(Lisp_Object *stack_ptr,
1085 const Opbyte *program_ptr, Opcode opcode)
1087 switch ((unsigned int)opcode) {
1089 case Bsave_excursion:
1090 record_unwind_protect(save_excursion_restore,
1091 save_excursion_save());
1094 case Bsave_window_excursion: {
1095 int count = specpdl_depth();
1096 record_unwind_protect(save_window_excursion_unwind,
1097 Fcurrent_window_configuration
1100 unbind_to(count, Qnil);
1104 case Bsave_restriction:
1105 record_unwind_protect(save_restriction_restore,
1106 save_restriction_save());
1110 Lisp_Object arg = POP;
1111 TOP = internal_catch(TOP, Feval, arg, 0);
1115 case Bskip_chars_backward: {
1116 Lisp_Object arg = POP;
1117 TOP = Fskip_chars_backward(TOP, arg, Qnil);
1121 case Bunwind_protect:
1122 record_unwind_protect(Fprogn, POP);
1125 case Bcondition_case: {
1126 Lisp_Object arg2 = POP; /* handlers */
1127 Lisp_Object arg1 = POP; /* bodyform */
1128 TOP = condition_case_3(arg1, TOP, arg2);
1133 Lisp_Object arg2 = POP;
1134 Lisp_Object arg1 = POP;
1135 TOP = Fset_marker(TOP, arg1, arg2);
1140 Lisp_Object arg = POP;
1141 TOP = ent_binop(ASE_BINARY_OP_REM, TOP, arg);
1145 case Bmatch_beginning:
1146 TOP = Fmatch_beginning(TOP);
1150 TOP = Fmatch_end(TOP);
1154 TOP = Fupcase(TOP, Qnil);
1158 TOP = Fdowncase(TOP, Qnil);
1162 Lisp_Object arg = POP;
1163 TOP = Ffset(TOP, arg);
1167 case Bstring_equal: {
1168 Lisp_Object arg = POP;
1169 TOP = Fstring_equal(TOP, arg);
1173 case Bstring_lessp: {
1174 Lisp_Object arg = POP;
1175 TOP = Fstring_lessp(TOP, arg);
1180 Lisp_Object arg2 = POP;
1181 Lisp_Object arg1 = POP;
1182 TOP = Fsubstring(TOP, arg1, arg2);
1186 case Bcurrent_column:
1187 PUSH(make_int(current_column(current_buffer)));
1191 TOP = Fchar_after(TOP, Qnil);
1195 TOP = Findent_to(TOP, Qnil, Qnil);
1202 case Bfollowing_char:
1203 PUSH(Ffollowing_char(Qnil));
1206 case Bpreceding_char:
1207 PUSH(Fpreceding_char(Qnil));
1226 case Bsave_current_buffer:
1227 record_unwind_protect(save_current_buffer_restore,
1231 case Binteractive_p:
1232 PUSH(Finteractive_p());
1236 TOP = Fforward_char(TOP, Qnil);
1240 TOP = Fforward_word(TOP, Qnil);
1244 TOP = Fforward_line(TOP, Qnil);
1248 TOP = Fchar_syntax(TOP, Qnil);
1251 case Bbuffer_substring: {
1252 Lisp_Object arg = POP;
1253 TOP = Fbuffer_substring(TOP, arg, Qnil);
1257 case Bdelete_region: {
1258 Lisp_Object arg = POP;
1259 TOP = Fdelete_region(TOP, arg, Qnil);
1263 case Bnarrow_to_region: {
1264 Lisp_Object arg = POP;
1265 TOP = Fnarrow_to_region(TOP, arg, Qnil);
1270 TOP = Fend_of_line(TOP, Qnil);
1273 case Btemp_output_buffer_setup:
1274 temp_output_buffer_setup(TOP);
1275 TOP = Vstandard_output;
1278 case Btemp_output_buffer_show: {
1279 Lisp_Object arg = POP;
1280 temp_output_buffer_show(TOP, Qnil);
1283 /* pop binding of standard-output */
1284 unbind_to(specpdl_depth() - 1, Qnil);
1290 Lisp_Object arg = POP;
1291 TOP = HACKEQ_UNSAFE(TOP, arg) ? Qt : Qnil;
1296 Lisp_Object arg = POP;
1297 TOP = Fold_memq(TOP, arg);
1302 Lisp_Object arg = POP;
1303 TOP = Fold_equal(TOP, arg);
1308 Lisp_Object arg = POP;
1309 TOP = Fold_member(TOP, arg);
1314 Lisp_Object arg = POP;
1315 TOP = Fold_assq(TOP, arg);
1327 static void invalid_byte_code_error(char *error_message, ...)
1331 int maxsz = strlen(error_message) + 128;
1332 char *buf = alloca_array(char, maxsz);
1334 int sz=snprintf(buf, maxsz, "%s", error_message);
1335 assert(sz>=0 && sz<maxsz);
1336 va_start(args, error_message);
1337 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(buf), Qnil, -1,
1341 signal_error(Qinvalid_byte_code, list1(obj));
1344 /* Check for valid opcodes. Change this when adding new opcodes. */
1345 static void check_opcode(Opcode opcode)
1347 if ((opcode < Bvarref) ||
1349 (opcode > BLAST_BEFORE_THREE_O_O && opcode < Bconstant))
1350 invalid_byte_code_error
1351 ("invalid opcode %d in instruction stream", opcode);
1354 /* Check that IDX is a valid offset into the `constants' vector */
1355 static void check_constants_index(int idx, Lisp_Object constants)
1357 if (idx < 0 || idx >= XVECTOR_LENGTH(constants))
1358 invalid_byte_code_error
1359 ("reference %d to constants array out of range 0, %d",
1360 idx, XVECTOR_LENGTH(constants) - 1);
1363 /* Get next character from Lisp instructions string. */
1364 #define READ_INSTRUCTION_CHAR(lvalue) do { \
1365 (lvalue) = charptr_emchar (ptr); \
1366 INC_CHARPTR (ptr); \
1367 *icounts_ptr++ = program_ptr - program; \
1368 if (lvalue > UCHAR_MAX) \
1369 invalid_byte_code_error \
1370 ("Invalid character %c in byte code string"); \
1373 /* Get opcode from Lisp instructions string. */
1374 #define READ_OPCODE do { \
1376 READ_INSTRUCTION_CHAR (c); \
1377 opcode = (Opcode) c; \
1380 /* Get next operand, a uint8, from Lisp instructions string. */
1381 #define READ_OPERAND_1 do { \
1382 READ_INSTRUCTION_CHAR (arg); \
1386 /* Get next operand, a uint16, from Lisp instructions string. */
1387 #define READ_OPERAND_2 do { \
1388 unsigned int arg1, arg2; \
1389 READ_INSTRUCTION_CHAR (arg1); \
1390 READ_INSTRUCTION_CHAR (arg2); \
1391 arg = arg1 + (arg2 << 8); \
1395 /* Write 1 byte to PTR, incrementing PTR */
1396 #define WRITE_INT8(value, ptr) do { \
1397 *((ptr)++) = (value); \
1400 /* Write 2 bytes to PTR, incrementing PTR */
1401 #define WRITE_INT16(value, ptr) do { \
1402 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \
1403 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \
1406 /* We've changed our minds about the opcode we've already written. */
1407 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
1409 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
1410 #define WRITE_NARGS(base_opcode) do { \
1413 REWRITE_OPCODE (base_opcode + arg); \
1415 else if (arg <= UCHAR_MAX) \
1417 REWRITE_OPCODE (base_opcode + 6); \
1418 WRITE_INT8 (arg, program_ptr); \
1422 REWRITE_OPCODE (base_opcode + 7); \
1423 WRITE_INT16 (arg, program_ptr); \
1427 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
1428 #define WRITE_CONSTANT do { \
1429 check_constants_index(arg, constants); \
1430 if (arg <= UCHAR_MAX - Bconstant) \
1432 REWRITE_OPCODE (Bconstant + arg); \
1436 REWRITE_OPCODE (Bconstant2); \
1437 WRITE_INT16 (arg, program_ptr); \
1441 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
1443 /* Compile byte code instructions into free space provided by caller, with
1444 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
1445 Returns length of compiled code. */
1446 static void optimize_byte_code(
1448 Lisp_Object instructions,
1449 Lisp_Object constants,
1451 Opbyte * const program,
1452 int *const program_length,
1453 int *const varbind_count)
1455 size_t instructions_length = XSTRING_LENGTH(instructions);
1456 size_t comfy_size = 2 * instructions_length;
1458 int *const icounts = alloca_array(int, comfy_size);
1459 int *icounts_ptr = icounts;
1461 /* We maintain a table of jumps in the source code. */
1466 struct jump *const jumps = alloca_array(struct jump, comfy_size);
1467 struct jump *jumps_ptr = jumps;
1469 Opbyte *program_ptr = program;
1471 /* const means constant! */
1472 Bufbyte *ptr = XSTRING_DATA(instructions);
1473 const Bufbyte *const end = ptr + instructions_length;
1484 switch ((unsigned int)opcode) {
1499 arg = opcode - Bvarref;
1501 check_constants_index(arg, constants);
1502 val = XVECTOR_DATA(constants)[arg];
1504 invalid_byte_code_error
1505 ("variable reference to non-symbol %S",
1507 if (EQ(val, Qnil) || EQ(val, Qt)
1508 || (SYMBOL_IS_KEYWORD(val)))
1509 invalid_byte_code_error
1510 ("variable reference to constant symbol %s",
1511 string_data(XSYMBOL(val)->name));
1512 WRITE_NARGS(Bvarref);
1527 arg = opcode - Bvarset;
1529 check_constants_index(arg, constants);
1530 val = XVECTOR_DATA(constants)[arg];
1532 invalid_byte_code_error
1533 ("attempt to set non-symbol %S", val);
1534 if (EQ(val, Qnil) || EQ(val, Qt))
1535 invalid_byte_code_error
1536 ("attempt to set constant symbol %s",
1537 string_data(XSYMBOL(val)->name));
1538 /* Ignore assignments to keywords by converting to Bdiscard.
1539 For backward compatibility only - we'd like to make this an error. */
1540 if (SYMBOL_IS_KEYWORD(val))
1541 REWRITE_OPCODE(Bdiscard);
1543 WRITE_NARGS(Bvarset);
1558 arg = opcode - Bvarbind;
1561 check_constants_index(arg, constants);
1562 val = XVECTOR_DATA(constants)[arg];
1564 invalid_byte_code_error
1565 ("attempt to let-bind non-symbol %S", val);
1566 if (EQ(val, Qnil) || EQ(val, Qt)
1567 || (SYMBOL_IS_KEYWORD(val)))
1568 invalid_byte_code_error
1569 ("attempt to let-bind constant symbol %s",
1570 string_data(XSYMBOL(val)->name));
1571 WRITE_NARGS(Bvarbind);
1586 arg = opcode - Bcall;
1603 arg = opcode - Bunbind;
1605 WRITE_NARGS(Bunbind);
1611 case Bgotoifnilelsepop:
1612 case Bgotoifnonnilelsepop:
1614 /* Make program_ptr-relative */
1615 arg += icounts - (icounts_ptr - argsize);
1620 case BRgotoifnonnil:
1621 case BRgotoifnilelsepop:
1622 case BRgotoifnonnilelsepop:
1624 /* Make program_ptr-relative */
1627 /* Record program-relative goto addresses in `jumps' table */
1628 jumps_ptr->from = icounts_ptr - icounts - argsize;
1629 jumps_ptr->to = jumps_ptr->from + arg;
1631 if (arg >= -1 && arg <= argsize)
1632 invalid_byte_code_error
1633 ("goto instruction is its own target");
1634 if (arg <= SCHAR_MIN || arg > SCHAR_MAX) {
1636 REWRITE_OPCODE(opcode + Bgoto - BRgoto);
1637 WRITE_INT16(arg, program_ptr);
1640 REWRITE_OPCODE(opcode + BRgoto - Bgoto);
1641 WRITE_INT8(arg, program_ptr);
1654 WRITE_INT8(arg, program_ptr);
1658 if (opcode < Bconstant)
1659 check_opcode(opcode);
1661 arg = opcode - Bconstant;
1668 /* Fix up jumps table to refer to NEW offsets. */
1669 for (struct jump *j = jumps; j < jumps_ptr; j++) {
1670 #ifdef ERROR_CHECK_BYTE_CODE
1671 assert(j->from < icounts_ptr - icounts);
1672 assert(j->to < icounts_ptr - icounts);
1674 j->from = icounts[j->from];
1675 j->to = icounts[j->to];
1676 #ifdef ERROR_CHECK_BYTE_CODE
1677 assert(j->from < program_ptr - program);
1678 assert(j->to < program_ptr - program);
1679 check_opcode((Opcode) (program[j->from - 1]));
1681 check_opcode((Opcode) (program[j->to]));
1684 /* Fixup jumps in byte-code until no more fixups needed */
1685 for (bool more_fixups_needed = true; more_fixups_needed; ) {
1688 /* assume we don't need more hiccups */
1689 more_fixups_needed = false;
1690 for (j = jumps; j < jumps_ptr; j++) {
1693 int jump = to - from;
1694 Opbyte *p = program + from;
1695 Opcode opcode = (Opcode)p[-1];
1697 if (!more_fixups_needed) {
1698 check_opcode((Opcode) p[jump]);
1700 assert(to >= 0 && program + to < program_ptr);
1702 switch ((unsigned int)opcode) {
1706 case Bgotoifnilelsepop:
1707 case Bgotoifnonnilelsepop:
1708 WRITE_INT16(jump, p);
1713 case BRgotoifnonnil:
1714 case BRgotoifnilelsepop:
1715 case BRgotoifnonnilelsepop:
1716 if (jump > SCHAR_MIN && jump <= SCHAR_MAX) {
1717 WRITE_INT8(jump, p);
1722 for (jj = jumps; jj < jumps_ptr; jj++) {
1724 program_ptr - program);
1726 program_ptr - program);
1727 if (jj->from > from) {
1730 if (jj->to > from) {
1734 p[-1] += Bgoto - BRgoto;
1735 more_fixups_needed = true;
1736 memmove(p + 1, p, program_ptr++ - p);
1737 WRITE_INT16(jump, p);
1748 /* *program_ptr++ = 0; */
1749 *program_length = program_ptr - program;
1752 /* Optimize the byte code and store the optimized program, only
1753 understood by bytecode.c, in an opaque object in the
1754 instructions slot of the Compiled_Function object. */
1755 void optimize_compiled_function(Lisp_Object compiled_function)
1757 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(compiled_function);
1762 /* If we have not actually read the bytecode string
1763 and constants vector yet, fetch them from the file. */
1764 if (CONSP(f->instructions))
1765 Ffetch_bytecode(compiled_function);
1767 if (STRINGP(f->instructions)) {
1768 /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1769 which would be slightly more `proper' */
1771 alloca_array(Opbyte,
1772 1 + 2 * XSTRING_LENGTH(f->instructions));
1773 optimize_byte_code(f->instructions, f->constants, program,
1774 &program_length, &varbind_count);
1775 f->specpdl_depth = XINT(Flength(f->arglist)) + varbind_count;
1777 make_opaque(program, program_length * sizeof(Opbyte));
1780 assert(OPAQUEP(f->instructions));
1783 /************************************************************************/
1784 /* The compiled-function object type */
1785 /************************************************************************/
1787 print_compiled_function(Lisp_Object obj, Lisp_Object printcharfun,
1790 /* This function can GC */
1791 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(obj); /* GC doesn't relocate */
1792 int docp = f->flags.documentationp;
1793 int intp = f->flags.interactivep;
1794 struct gcpro gcpro1, gcpro2;
1795 GCPRO2(obj, printcharfun);
1797 write_c_string(print_readably ? "#[" : "#<compiled-function ",
1799 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1800 if (!print_readably) {
1801 Lisp_Object ann = compiled_function_annotation(f);
1803 write_c_string("(from ", printcharfun);
1804 print_internal(ann, printcharfun, 1);
1805 write_c_string(") ", printcharfun);
1808 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1809 /* COMPILED_ARGLIST = 0 */
1810 print_internal(compiled_function_arglist(f), printcharfun, escapeflag);
1812 /* COMPILED_INSTRUCTIONS = 1 */
1813 write_c_string(" ", printcharfun);
1815 struct gcpro ngcpro1;
1816 Lisp_Object instructions = compiled_function_instructions(f);
1817 NGCPRO1(instructions);
1818 if (STRINGP(instructions) && !print_readably) {
1819 /* We don't usually want to see that junk in the bytecode. */
1820 write_fmt_str(printcharfun, "\"...(%ld)\"",
1821 (long)XSTRING_CHAR_LENGTH(instructions));
1823 print_internal(instructions, printcharfun, escapeflag);
1827 /* COMPILED_CONSTANTS = 2 */
1828 write_c_string(" ", printcharfun);
1829 print_internal(compiled_function_constants(f), printcharfun,
1832 /* COMPILED_STACK_DEPTH = 3 */
1833 write_fmt_str(printcharfun, " %d", compiled_function_stack_depth(f));
1835 /* COMPILED_DOC_STRING = 4 */
1837 write_c_string(" ", printcharfun);
1838 print_internal(compiled_function_documentation(f), printcharfun,
1842 /* COMPILED_INTERACTIVE = 5 */
1844 write_c_string(" ", printcharfun);
1845 print_internal(compiled_function_interactive(f), printcharfun,
1850 write_c_string(print_readably ? "]" : ">", printcharfun);
1853 static Lisp_Object mark_compiled_function(Lisp_Object obj)
1855 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(obj);
1857 mark_object(f->instructions);
1858 mark_object(f->arglist);
1859 mark_object(f->doc_and_interactive);
1860 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1861 mark_object(f->annotated);
1863 /* tail-recurse on constants */
1864 return f->constants;
1868 compiled_function_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
1870 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION(obj1);
1871 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION(obj2);
1872 return (f1->flags.documentationp == f2->flags.documentationp && f1->flags.interactivep == f2->flags.interactivep && f1->flags.domainp == f2->flags.domainp && /* I18N3 */
1873 internal_equal(compiled_function_instructions(f1),
1874 compiled_function_instructions(f2), depth + 1) &&
1875 internal_equal(f1->constants, f2->constants, depth + 1) &&
1876 internal_equal(f1->arglist, f2->arglist, depth + 1) &&
1877 internal_equal(f1->doc_and_interactive,
1878 f2->doc_and_interactive, depth + 1));
1881 static unsigned long compiled_function_hash(Lisp_Object obj, int depth)
1883 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(obj);
1884 return HASH3((f->flags.documentationp << 2) +
1885 (f->flags.interactivep << 1) +
1887 internal_hash(f->instructions, depth + 1),
1888 internal_hash(f->constants, depth + 1));
1891 static const struct lrecord_description compiled_function_description[] = {
1892 {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, instructions)},
1893 {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, constants)},
1894 {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, arglist)},
1895 {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, doc_and_interactive)},
1896 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1897 {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, annotated)},
1902 DEFINE_BASIC_LRECORD_IMPLEMENTATION("compiled-function", compiled_function,
1903 mark_compiled_function,
1904 print_compiled_function, 0,
1905 compiled_function_equal,
1906 compiled_function_hash,
1907 compiled_function_description,
1908 Lisp_Compiled_Function);
1910 DEFUN("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
1911 Return t if OBJECT is a byte-compiled function object.
1915 return COMPILED_FUNCTIONP(object) ? Qt : Qnil;
1918 /************************************************************************/
1919 /* compiled-function object accessor functions */
1920 /************************************************************************/
1922 Lisp_Object compiled_function_arglist(Lisp_Compiled_Function * f)
1927 Lisp_Object compiled_function_instructions(Lisp_Compiled_Function * f)
1929 if (!OPAQUEP(f->instructions))
1930 return f->instructions;
1933 /* Invert action performed by optimize_byte_code() */
1934 Lisp_Opaque *opaque = XOPAQUE(f->instructions);
1936 Bufbyte *const buffer =
1937 alloca_array(Bufbyte, OPAQUE_SIZE(opaque) * MAX_EMCHAR_LEN);
1938 Bufbyte *bp = buffer;
1940 const Opbyte *const program =
1941 (const Opbyte *)OPAQUE_DATA(opaque);
1942 const Opbyte *program_ptr = program;
1943 const Opbyte *const program_end =
1944 program_ptr + OPAQUE_SIZE(opaque);
1946 while (program_ptr < program_end) {
1947 Opcode opcode = (Opcode) READ_UINT_1;
1948 bp += set_charptr_emchar(bp, opcode);
1950 switch ((unsigned int)opcode) {
1957 bp += set_charptr_emchar(bp, READ_UINT_1);
1958 bp += set_charptr_emchar(bp, READ_UINT_1);
1969 bp += set_charptr_emchar(bp, READ_UINT_1);
1975 case Bgotoifnilelsepop:
1976 case Bgotoifnonnilelsepop:
1978 int jump = READ_INT_2;
1980 Opbyte *buf2p = buf2;
1981 /* Convert back to program-relative address */
1983 (program_ptr - 2 - program),
1985 bp += set_charptr_emchar(bp, buf2[0]);
1986 bp += set_charptr_emchar(bp, buf2[1]);
1992 case BRgotoifnonnil:
1993 case BRgotoifnilelsepop:
1994 case BRgotoifnonnilelsepop:
1995 bp += set_charptr_emchar(bp, READ_INT_1 + 127);
2002 return make_string(buffer, bp - buffer);
2006 Lisp_Object compiled_function_constants(Lisp_Compiled_Function * f)
2008 return f->constants;
2011 int compiled_function_stack_depth(Lisp_Compiled_Function * f)
2013 return f->stack_depth;
2016 /* The compiled_function->doc_and_interactive slot uses the minimal
2017 number of conses, based on compiled_function->flags; it may take
2018 any of the following forms:
2025 (interactive . domain)
2026 (doc . (interactive . domain))
2029 /* Caller must check flags.interactivep first */
2030 Lisp_Object compiled_function_interactive(Lisp_Compiled_Function * f)
2032 assert(f->flags.interactivep);
2033 if (f->flags.documentationp && f->flags.domainp)
2034 return XCAR(XCDR(f->doc_and_interactive));
2035 else if (f->flags.documentationp)
2036 return XCDR(f->doc_and_interactive);
2037 else if (f->flags.domainp)
2038 return XCAR(f->doc_and_interactive);
2040 return f->doc_and_interactive;
2043 /* Caller need not check flags.documentationp first */
2044 Lisp_Object compiled_function_documentation(Lisp_Compiled_Function * f)
2046 if (!f->flags.documentationp)
2048 else if (f->flags.interactivep && f->flags.domainp)
2049 return XCAR(f->doc_and_interactive);
2050 else if (f->flags.interactivep)
2051 return XCAR(f->doc_and_interactive);
2052 else if (f->flags.domainp)
2053 return XCAR(f->doc_and_interactive);
2055 return f->doc_and_interactive;
2058 /* Caller need not check flags.domainp first */
2059 Lisp_Object compiled_function_domain(Lisp_Compiled_Function * f)
2061 if (!f->flags.domainp)
2063 else if (f->flags.documentationp && f->flags.interactivep)
2064 return XCDR(XCDR(f->doc_and_interactive));
2065 else if (f->flags.documentationp)
2066 return XCDR(f->doc_and_interactive);
2067 else if (f->flags.interactivep)
2068 return XCDR(f->doc_and_interactive);
2070 return f->doc_and_interactive;
2073 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2075 Lisp_Object compiled_function_annotation(Lisp_Compiled_Function * f)
2077 return f->annotated;
2082 /* used only by Snarf-documentation; there must be doc already. */
2084 set_compiled_function_documentation(Lisp_Compiled_Function * f,
2085 Lisp_Object new_doc)
2087 assert(f->flags.documentationp);
2088 assert(INTP(new_doc) || STRINGP(new_doc));
2090 if (f->flags.interactivep && f->flags.domainp)
2091 XCAR(f->doc_and_interactive) = new_doc;
2092 else if (f->flags.interactivep)
2093 XCAR(f->doc_and_interactive) = new_doc;
2094 else if (f->flags.domainp)
2095 XCAR(f->doc_and_interactive) = new_doc;
2097 f->doc_and_interactive = new_doc;
2100 DEFUN("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2101 Return the argument list of the compiled-function object FUNCTION.
2105 CHECK_COMPILED_FUNCTION(function);
2106 return compiled_function_arglist(XCOMPILED_FUNCTION(function));
2109 DEFUN("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
2110 Return the byte-opcode string of the compiled-function object FUNCTION.
2114 CHECK_COMPILED_FUNCTION(function);
2115 return compiled_function_instructions(XCOMPILED_FUNCTION(function));
2118 DEFUN("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
2119 Return the constants vector of the compiled-function object FUNCTION.
2123 CHECK_COMPILED_FUNCTION(function);
2124 return compiled_function_constants(XCOMPILED_FUNCTION(function));
2127 DEFUN("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2128 Return the maximum stack depth of the compiled-function object FUNCTION.
2132 CHECK_COMPILED_FUNCTION(function);
2134 make_int(compiled_function_stack_depth
2135 (XCOMPILED_FUNCTION(function)));
2138 DEFUN("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
2139 Return the doc string of the compiled-function object FUNCTION, if available.
2140 Functions that had their doc strings snarfed into the DOC file will have
2141 an integer returned instead of a string.
2145 CHECK_COMPILED_FUNCTION(function);
2146 return compiled_function_documentation(XCOMPILED_FUNCTION(function));
2149 DEFUN("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2150 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2151 If non-nil, the return value will be a list whose first element is
2152 `interactive' and whose second element is the interactive spec.
2156 CHECK_COMPILED_FUNCTION(function);
2157 return XCOMPILED_FUNCTION(function)->flags.interactivep
2158 ? list2(Qinteractive,
2159 compiled_function_interactive(XCOMPILED_FUNCTION(function)))
2163 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2165 /* Remove the `xx' if you wish to restore this feature */
2166 xxDEFUN("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2167 Return the annotation of the compiled-function object FUNCTION, or nil.
2168 The annotation is a piece of information indicating where this
2169 compiled-function object came from. Generally this will be
2170 a symbol naming a function; or a string naming a file, if the
2171 compiled-function object was not defined in a function; or nil,
2172 if the compiled-function object was not created as a result of
2176 CHECK_COMPILED_FUNCTION(function);
2177 return compiled_function_annotation(XCOMPILED_FUNCTION(function));
2180 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2182 DEFUN("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
2183 Return the domain of the compiled-function object FUNCTION, or nil.
2184 This is only meaningful if I18N3 was enabled when emacs was compiled.
2188 CHECK_COMPILED_FUNCTION(function);
2189 return XCOMPILED_FUNCTION(function)->flags.domainp
2190 ? compiled_function_domain(XCOMPILED_FUNCTION(function))
2194 DEFUN("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
2195 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2199 Lisp_Compiled_Function *f;
2200 CHECK_COMPILED_FUNCTION(function);
2201 f = XCOMPILED_FUNCTION(function);
2203 if (OPAQUEP(f->instructions) || STRINGP(f->instructions))
2206 if (CONSP(f->instructions)) {
2207 Lisp_Object tem = read_doc_string(f->instructions);
2209 signal_simple_error("Invalid lazy-loaded byte code",
2211 /* v18 or v19 bytecode file. Need to Ebolify. */
2212 if (f->flags.ebolified && VECTORP(XCDR(tem)))
2213 ebolify_bytecode_constants(XCDR(tem));
2214 f->instructions = XCAR(tem);
2215 f->constants = XCDR(tem);
2219 return Qnil; /* not reached */
2222 DEFUN("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
2223 Convert compiled function FUNCTION into an optimized internal form.
2227 Lisp_Compiled_Function *f;
2228 CHECK_COMPILED_FUNCTION(function);
2229 f = XCOMPILED_FUNCTION(function);
2231 if (OPAQUEP(f->instructions)) /* Already optimized? */
2234 optimize_compiled_function(function);
2238 DEFUN("byte-code", Fbyte_code, 3, 3, 0, /*
2239 Function used internally in byte-compiled code.
2240 First argument INSTRUCTIONS is a string of byte code.
2241 Second argument CONSTANTS is a vector of constants.
2242 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2243 If STACK-DEPTH is incorrect, Emacs may crash.
2245 (instructions, constants, stack_depth))
2247 /* This function can GC */
2252 CHECK_STRING(instructions);
2253 CHECK_VECTOR(constants);
2254 CHECK_NATNUM(stack_depth);
2256 /* Optimize the `instructions' string, just like when executing a
2257 regular compiled function, but don't save it for later since this is
2258 likely to only be executed once. */
2259 program = alloca_array(Opbyte, 1 + 2 * XSTRING_LENGTH(instructions));
2260 optimize_byte_code(instructions, constants, program,
2261 &program_length, &varbind_count);
2262 SPECPDL_RESERVE(varbind_count);
2263 return execute_optimized_program(program,
2265 XVECTOR_DATA(constants));
2268 void syms_of_bytecode(void)
2270 INIT_LRECORD_IMPLEMENTATION(compiled_function);
2272 DEFERROR_STANDARD(Qinvalid_byte_code, Qinvalid_state);
2273 defsymbol(&Qbyte_code, "byte-code");
2274 defsymbol(&Qcompiled_functionp, "compiled-function-p");
2276 DEFSUBR(Fbyte_code);
2277 DEFSUBR(Ffetch_bytecode);
2278 DEFSUBR(Foptimize_compiled_function);
2280 DEFSUBR(Fcompiled_function_p);
2281 DEFSUBR(Fcompiled_function_instructions);
2282 DEFSUBR(Fcompiled_function_constants);
2283 DEFSUBR(Fcompiled_function_stack_depth);
2284 DEFSUBR(Fcompiled_function_arglist);
2285 DEFSUBR(Fcompiled_function_interactive);
2286 DEFSUBR(Fcompiled_function_doc_string);
2287 DEFSUBR(Fcompiled_function_domain);
2288 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2289 DEFSUBR(Fcompiled_function_annotation);
2292 #ifdef BYTE_CODE_METER
2293 defsymbol(&Qbyte_code_meter, "byte-code-meter");
2297 void vars_of_bytecode(void)
2299 #ifdef BYTE_CODE_METER
2301 DEFVAR_LISP("byte-code-meter", &Vbyte_code_meter /*
2302 A vector of vectors which holds a histogram of byte code usage.
2303 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2304 opcode CODE has been executed.
2305 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2306 indicates how many times the byte opcodes CODE1 and CODE2 have been
2307 executed in succession.
2309 DEFVAR_BOOL("byte-metering-on", &byte_metering_on /*
2310 If non-nil, keep profiling information on byte code usage.
2311 The variable `byte-code-meter' indicates how often each byte opcode is used.
2312 If a symbol has a property named `byte-code-meter' whose value is an
2313 integer, it is incremented each time that symbol's function is called.
2316 byte_metering_on = 0;
2317 Vbyte_code_meter = make_vector(256, Qzero);
2321 XVECTOR_DATA(Vbyte_code_meter)[i] =
2322 make_vector(256, Qzero);
2324 #endif /* BYTE_CODE_METER */