Mercurial > hg > xemacs-beta

comparison src/bytecode.c @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents de805c49cfc1
children da8ed4261e83
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
26 26
27 /* Authorship: 27 /* Authorship:
28 28
29 FSF: long ago. 29 FSF: long ago.
30 30
31 hacked on by jwz@jwz.org 1991-06 31 hacked on by jwz@netscape.com 1991-06
32 o added a compile-time switch to turn on simple sanity checking; 32 o added a compile-time switch to turn on simple sanity checking;
33 o put back the obsolete byte-codes for error-detection; 33 o put back the obsolete byte-codes for error-detection;
34 o added a new instruction, unbind_all, which I will use for 34 o added a new instruction, unbind_all, which I will use for
35 tail-recursion elimination; 35 tail-recursion elimination;
36 o made temp_output_buffer_show be called with the right number 36 o made temp_output_buffer_show be called with the right number
53 #include "backtrace.h" 53 #include "backtrace.h"
54 #include "buffer.h" 54 #include "buffer.h"
55 #include "bytecode.h" 55 #include "bytecode.h"
56 #include "opaque.h" 56 #include "opaque.h"
57 #include "syntax.h" 57 #include "syntax.h"
58
59 #include <stddef.h>
60 #include <limits.h>
58 61
59 EXFUN (Ffetch_bytecode, 1); 62 EXFUN (Ffetch_bytecode, 1);
60 63
61 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code; 64 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
62 65
212 215
213 216
214 static void invalid_byte_code_error (char *error_message, ...); 217 static void invalid_byte_code_error (char *error_message, ...);
215 218
216 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr, 219 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
217 const Opbyte *program_ptr, 220 CONST Opbyte *program_ptr,
218 Opcode opcode); 221 Opcode opcode);
219 222
220 static Lisp_Object execute_optimized_program (const Opbyte *program, 223 static Lisp_Object execute_optimized_program (CONST Opbyte *program,
221 int stack_depth, 224 int stack_depth,
222 Lisp_Object *constants_data); 225 Lisp_Object *constants_data);
223 226
224 extern Lisp_Object Qand_rest, Qand_optional; 227 extern Lisp_Object Qand_rest, Qand_optional;
228
229 /* Define ERROR_CHECK_BYTE_CODE to enable some minor sanity checking.
230 Useful for debugging the byte compiler. */
231 #ifdef DEBUG_XEMACS
232 #define ERROR_CHECK_BYTE_CODE
233 #endif
225 234
226 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram. 235 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
227 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */ 236 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
228 /* #define BYTE_CODE_METER */ 237 /* #define BYTE_CODE_METER */
229 238
231 #ifdef BYTE_CODE_METER 240 #ifdef BYTE_CODE_METER
232 241
233 Lisp_Object Vbyte_code_meter, Qbyte_code_meter; 242 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
234 int byte_metering_on; 243 int byte_metering_on;
235 244
236 static void 245 #define METER_2(code1, code2) \
237 meter_code (Opcode prev_opcode, Opcode this_opcode) 246 XINT (XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[(code1)])[(code2)])
238 { 247
239 if (byte_metering_on) 248 #define METER_1(code) METER_2 (0, (code))
240 { 249
241 Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]); 250 #define METER_CODE(last_code, this_code) do { \
242 p[0] = INT_PLUS1 (p[0]); 251 if (byte_metering_on) \
243 if (prev_opcode) 252 { \
244 p[prev_opcode] = INT_PLUS1 (p[prev_opcode]); 253 if (METER_1 (this_code) != ((1<<VALBITS)-1)) \
245 } 254 METER_1 (this_code)++; \
246 } 255 if (last_code \
256 && METER_2 (last_code, this_code) != ((1<<VALBITS)-1)) \
257 METER_2 (last_code, this_code)++; \
258 } \
259 } while (0)
247 260
248 #endif /* BYTE_CODE_METER */ 261 #endif /* BYTE_CODE_METER */
249 262
250 263
251 static Lisp_Object 264 static Lisp_Object
252 bytecode_negate (Lisp_Object obj) 265 bytecode_negate (Lisp_Object obj)
253 { 266 {
254 retry: 267 retry:
255 268
256 if (INTP (obj)) return make_int (- XINT (obj));
257 #ifdef LISP_FLOAT_TYPE 269 #ifdef LISP_FLOAT_TYPE
258 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj)); 270 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
259 #endif 271 #endif
260 if (CHARP (obj)) return make_int (- ((int) XCHAR (obj))); 272 if (CHARP (obj)) return make_int (- ((int) XCHAR (obj)));
261 if (MARKERP (obj)) return make_int (- ((int) marker_position (obj))); 273 if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));
274 if (INTP (obj)) return make_int (- XINT (obj));
262 275
263 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); 276 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
264 goto retry; 277 goto retry;
265 } 278 }
266 279
290 { 303 {
291 retry: 304 retry:
292 305
293 #ifdef LISP_FLOAT_TYPE 306 #ifdef LISP_FLOAT_TYPE
294 { 307 {
295 EMACS_INT ival1, ival2; 308 int ival1, ival2;
296 309
297 if (INTP (obj1)) ival1 = XINT (obj1); 310 if (INTP (obj1)) ival1 = XINT (obj1);
298 else if (CHARP (obj1)) ival1 = XCHAR (obj1); 311 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
299 else if (MARKERP (obj1)) ival1 = marker_position (obj1); 312 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
300 else goto arithcompare_float; 313 else goto arithcompare_float;
334 347
335 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; 348 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
336 } 349 }
337 #else /* !LISP_FLOAT_TYPE */ 350 #else /* !LISP_FLOAT_TYPE */
338 { 351 {
339 EMACS_INT ival1, ival2; 352 int ival1, ival2;
340 353
341 if (INTP (obj1)) ival1 = XINT (obj1); 354 if (INTP (obj1)) ival1 = XINT (obj1);
342 else if (CHARP (obj1)) ival1 = XCHAR (obj1); 355 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
343 else if (MARKERP (obj1)) ival1 = marker_position (obj1); 356 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
344 else 357 else
363 376
364 static Lisp_Object 377 static Lisp_Object
365 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode) 378 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
366 { 379 {
367 #ifdef LISP_FLOAT_TYPE 380 #ifdef LISP_FLOAT_TYPE
368 EMACS_INT ival1, ival2; 381 int ival1, ival2;
369 int float_p; 382 int float_p;
370 383
371 retry: 384 retry:
372 385
373 float_p = 0; 386 float_p = 0;
425 case Bmin: if (dval1 > dval2) dval1 = dval2; break; 438 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
426 } 439 }
427 return make_float (dval1); 440 return make_float (dval1);
428 } 441 }
429 #else /* !LISP_FLOAT_TYPE */ 442 #else /* !LISP_FLOAT_TYPE */
430 EMACS_INT ival1, ival2; 443 int ival1, ival2;
431 444
432 retry: 445 retry:
433 446
434 if (INTP (obj1)) ival1 = XINT (obj1); 447 if (INTP (obj1)) ival1 = XINT (obj1);
435 else if (CHARP (obj1)) ival1 = XCHAR (obj1); 448 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
523 UNBIND_TO_GCPRO (speccount, value); 536 UNBIND_TO_GCPRO (speccount, value);
524 return value; 537 return value;
525 } 538 }
526 539
527 wrong_number_of_arguments: 540 wrong_number_of_arguments:
528 /* The actual printed compiled_function object is incomprehensible.
529 Check the backtrace to see if we can get a more meaningful symbol. */
530 if (EQ (fun, indirect_function (*backtrace_list->function, 0)))
531 fun = *backtrace_list->function;
532 return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs))); 541 return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
533 } 542 }
534 543
535 544
536 /* Read next uint8 from the instruction stream. */ 545 /* Read next uint8 from the instruction stream. */
592 Don't change the constructs unless you are willing to do 601 Don't change the constructs unless you are willing to do
593 real benchmarking and profiling work -- martin */ 602 real benchmarking and profiling work -- martin */
594 603
595 604
596 static Lisp_Object 605 static Lisp_Object
597 execute_optimized_program (const Opbyte *program, 606 execute_optimized_program (CONST Opbyte *program,
598 int stack_depth, 607 int stack_depth,
599 Lisp_Object *constants_data) 608 Lisp_Object *constants_data)
600 { 609 {
601 /* This function can GC */ 610 /* This function can GC */
602 REGISTER const Opbyte *program_ptr = (Opbyte *) program; 611 REGISTER CONST Opbyte *program_ptr = (Opbyte *) program;
603 REGISTER Lisp_Object *stack_ptr 612 REGISTER Lisp_Object *stack_ptr
604 = alloca_array (Lisp_Object, stack_depth + 1); 613 = alloca_array (Lisp_Object, stack_depth + 1);
605 int speccount = specpdl_depth (); 614 int speccount = specpdl_depth ();
606 struct gcpro gcpro1; 615 struct gcpro gcpro1;
607 616
639 #endif 648 #endif
640 649
641 #ifdef BYTE_CODE_METER 650 #ifdef BYTE_CODE_METER
642 prev_opcode = this_opcode; 651 prev_opcode = this_opcode;
643 this_opcode = opcode; 652 this_opcode = opcode;
644 meter_code (prev_opcode, this_opcode); 653 METER_CODE (prev_opcode, this_opcode);
645 #endif 654 #endif
646 655
647 switch (opcode) 656 switch (opcode)
648 { 657 {
649 REGISTER int n; 658 REGISTER int n;
682 case Bvarset+7: n = READ_UINT_2; goto do_varset; 691 case Bvarset+7: n = READ_UINT_2; goto do_varset;
683 case Bvarset+6: n = READ_UINT_1; /* most common */ 692 case Bvarset+6: n = READ_UINT_1; /* most common */
684 do_varset: 693 do_varset:
685 { 694 {
686 Lisp_Object symbol = constants_data[n]; 695 Lisp_Object symbol = constants_data[n];
687 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); 696 struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
688 Lisp_Object old_value = symbol_ptr->value; 697 Lisp_Object old_value = symbol_ptr->value;
689 Lisp_Object new_value = POP; 698 Lisp_Object new_value = POP;
690 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) 699 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
691 symbol_ptr->value = new_value; 700 symbol_ptr->value = new_value;
692 else 701 else
703 case Bvarbind+7: n = READ_UINT_2; goto do_varbind; 712 case Bvarbind+7: n = READ_UINT_2; goto do_varbind;
704 case Bvarbind+6: n = READ_UINT_1; /* most common */ 713 case Bvarbind+6: n = READ_UINT_1; /* most common */
705 do_varbind: 714 do_varbind:
706 { 715 {
707 Lisp_Object symbol = constants_data[n]; 716 Lisp_Object symbol = constants_data[n];
708 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); 717 struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
709 Lisp_Object old_value = symbol_ptr->value; 718 Lisp_Object old_value = symbol_ptr->value;
710 Lisp_Object new_value = POP; 719 Lisp_Object new_value = POP;
711 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) 720 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
712 { 721 {
713 specpdl_ptr->symbol = symbol; 722 specpdl_ptr->symbol = symbol;
756 UNBIND_TO (specpdl_depth() - 765 UNBIND_TO (specpdl_depth() -
757 (opcode < Bunbind+6 ? opcode-Bunbind : 766 (opcode < Bunbind+6 ? opcode-Bunbind :
758 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2)); 767 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
759 break; 768 break;
760 769
761
762 case Bgoto: 770 case Bgoto:
763 JUMP; 771 JUMP;
764 break; 772 break;
765 773
766 case Bgotoifnil: 774 case Bgotoifnil:
994 TOP = Fget (TOP, arg, Qnil); 1002 TOP = Fget (TOP, arg, Qnil);
995 break; 1003 break;
996 } 1004 }
997 1005
998 case Bsub1: 1006 case Bsub1:
999 TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP); 1007 TOP = INTP (TOP) ? make_int (XINT (TOP) - 1) : Fsub1 (TOP);
1000 break; 1008 break;
1001 1009
1002 case Badd1: 1010 case Badd1:
1003 TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP); 1011 TOP = INTP (TOP) ? make_int (XINT (TOP) + 1) : Fadd1 (TOP);
1004 break; 1012 break;
1005 1013
1006 1014
1007 case Beqlsign: 1015 case Beqlsign:
1008 { 1016 {
1052 case Bplus: 1060 case Bplus:
1053 { 1061 {
1054 Lisp_Object arg2 = POP; 1062 Lisp_Object arg2 = POP;
1055 Lisp_Object arg1 = TOP; 1063 Lisp_Object arg1 = TOP;
1056 TOP = INTP (arg1) && INTP (arg2) ? 1064 TOP = INTP (arg1) && INTP (arg2) ?
1057 INT_PLUS (arg1, arg2) : 1065 make_int (XINT (arg1) + XINT (arg2)) :
1058 bytecode_arithop (arg1, arg2, opcode); 1066 bytecode_arithop (arg1, arg2, opcode);
1059 break; 1067 break;
1060 } 1068 }
1061 1069
1062 case Bdiff: 1070 case Bdiff:
1063 { 1071 {
1064 Lisp_Object arg2 = POP; 1072 Lisp_Object arg2 = POP;
1065 Lisp_Object arg1 = TOP; 1073 Lisp_Object arg1 = TOP;
1066 TOP = INTP (arg1) && INTP (arg2) ? 1074 TOP = INTP (arg1) && INTP (arg2) ?
1067 INT_MINUS (arg1, arg2) : 1075 make_int (XINT (arg1) - XINT (arg2)) :
1068 bytecode_arithop (arg1, arg2, opcode); 1076 bytecode_arithop (arg1, arg2, opcode);
1069 break; 1077 break;
1070 } 1078 }
1071 1079
1072 case Bmult: 1080 case Bmult:
1104 { 1112 {
1105 Lisp_Object arg = POP; 1113 Lisp_Object arg = POP;
1106 TOP = Fmemq (TOP, arg); 1114 TOP = Fmemq (TOP, arg);
1107 break; 1115 break;
1108 } 1116 }
1117
1109 1118
1110 case Bset: 1119 case Bset:
1111 { 1120 {
1112 Lisp_Object arg = POP; 1121 Lisp_Object arg = POP;
1113 TOP = Fset (TOP, arg); 1122 TOP = Fset (TOP, arg);
1217 rarely executed code, to minimize cache misses. 1226 rarely executed code, to minimize cache misses.
1218 1227
1219 Don't make this function static, since then the compiler might inline it. */ 1228 Don't make this function static, since then the compiler might inline it. */
1220 Lisp_Object * 1229 Lisp_Object *
1221 execute_rare_opcode (Lisp_Object *stack_ptr, 1230 execute_rare_opcode (Lisp_Object *stack_ptr,
1222 const Opbyte *program_ptr, 1231 CONST Opbyte *program_ptr,
1223 Opcode opcode) 1232 Opcode opcode)
1224 { 1233 {
1225 switch (opcode) 1234 switch (opcode)
1226 { 1235 {
1227 1236
1487 va_list args; 1496 va_list args;
1488 char *buf = alloca_array (char, strlen (error_message) + 128); 1497 char *buf = alloca_array (char, strlen (error_message) + 128);
1489 1498
1490 sprintf (buf, "%s", error_message); 1499 sprintf (buf, "%s", error_message);
1491 va_start (args, error_message); 1500 va_start (args, error_message);
1492 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (buf), Qnil, -1, 1501 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (buf), Qnil, -1,
1493 args); 1502 args);
1494 va_end (args); 1503 va_end (args);
1495 1504
1496 signal_error (Qinvalid_byte_code, list1 (obj)); 1505 signal_error (Qinvalid_byte_code, list1 (obj));
1497 } 1506 }
1603 static void 1612 static void
1604 optimize_byte_code (/* in */ 1613 optimize_byte_code (/* in */
1605 Lisp_Object instructions, 1614 Lisp_Object instructions,
1606 Lisp_Object constants, 1615 Lisp_Object constants,
1607 /* out */ 1616 /* out */
1608 Opbyte * const program, 1617 Opbyte * CONST program,
1609 int * const program_length, 1618 int * CONST program_length,
1610 int * const varbind_count) 1619 int * CONST varbind_count)
1611 { 1620 {
1612 size_t instructions_length = XSTRING_LENGTH (instructions); 1621 size_t instructions_length = XSTRING_LENGTH (instructions);
1613 size_t comfy_size = 2 * instructions_length; 1622 size_t comfy_size = 2 * instructions_length;
1614 1623
1615 int * const icounts = alloca_array (int, comfy_size); 1624 int * CONST icounts = alloca_array (int, comfy_size);
1616 int * icounts_ptr = icounts; 1625 int * icounts_ptr = icounts;
1617 1626
1618 /* We maintain a table of jumps in the source code. */ 1627 /* We maintain a table of jumps in the source code. */
1619 struct jump 1628 struct jump
1620 { 1629 {
1621 int from; 1630 int from;
1622 int to; 1631 int to;
1623 }; 1632 };
1624 struct jump * const jumps = alloca_array (struct jump, comfy_size); 1633 struct jump * CONST jumps = alloca_array (struct jump, comfy_size);
1625 struct jump *jumps_ptr = jumps; 1634 struct jump *jumps_ptr = jumps;
1626 1635
1627 Opbyte *program_ptr = program; 1636 Opbyte *program_ptr = program;
1628 1637
1629 const Bufbyte *ptr = XSTRING_DATA (instructions); 1638 CONST Bufbyte *ptr = XSTRING_DATA (instructions);
1630 const Bufbyte * const end = ptr + instructions_length; 1639 CONST Bufbyte * CONST end = ptr + instructions_length;
1631 1640
1632 *varbind_count = 0; 1641 *varbind_count = 0;
1633 1642
1634 while (ptr < end) 1643 while (ptr < end)
1635 { 1644 {
1890 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions)); 1899 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
1891 optimize_byte_code (f->instructions, f->constants, 1900 optimize_byte_code (f->instructions, f->constants,
1892 program, &program_length, &varbind_count); 1901 program, &program_length, &varbind_count);
1893 f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count; 1902 f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
1894 f->instructions = 1903 f->instructions =
1895 make_opaque (program, program_length * sizeof (Opbyte)); 1904 Fpurecopy (make_opaque (program_length * sizeof (Opbyte),
1905 (CONST void *) program));
1896 } 1906 }
1897 1907
1898 assert (OPAQUEP (f->instructions)); 1908 assert (OPAQUEP (f->instructions));
1899 } 1909 }
1900 1910
1976 write_c_string (print_readably ? "]" : ">", printcharfun); 1986 write_c_string (print_readably ? "]" : ">", printcharfun);
1977 } 1987 }
1978 1988
1979 1989
1980 static Lisp_Object 1990 static Lisp_Object
1981 mark_compiled_function (Lisp_Object obj) 1991 mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object))
1982 { 1992 {
1983 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); 1993 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1984 1994
1985 mark_object (f->instructions); 1995 markobj (f->instructions);
1986 mark_object (f->arglist); 1996 markobj (f->arglist);
1987 mark_object (f->doc_and_interactive); 1997 markobj (f->doc_and_interactive);
1988 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK 1998 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1989 mark_object (f->annotated); 1999 markobj (f->annotated);
1990 #endif 2000 #endif
1991 /* tail-recurse on constants */ 2001 /* tail-recurse on constants */
1992 return f->constants; 2002 return f->constants;
1993 } 2003 }
1994 2004
2018 f->flags.domainp, 2028 f->flags.domainp,
2019 internal_hash (f->instructions, depth + 1), 2029 internal_hash (f->instructions, depth + 1),
2020 internal_hash (f->constants, depth + 1)); 2030 internal_hash (f->constants, depth + 1));
2021 } 2031 }
2022 2032
2023 static const struct lrecord_description compiled_function_description[] = {
2024 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
2025 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
2026 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
2027 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
2028 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2029 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
2030 #endif
2031 { XD_END }
2032 };
2033
2034 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function, 2033 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
2035 mark_compiled_function, 2034 mark_compiled_function,
2036 print_compiled_function, 0, 2035 print_compiled_function, 0,
2037 compiled_function_equal, 2036 compiled_function_equal,
2038 compiled_function_hash, 2037 compiled_function_hash,
2039 compiled_function_description,
2040 Lisp_Compiled_Function); 2038 Lisp_Compiled_Function);
2041 2039
2042 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* 2040 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
2043 Return t if OBJECT is a byte-compiled function object. 2041 Return t if OBJECT is a byte-compiled function object.
2044 */ 2042 */
2065 2063
2066 { 2064 {
2067 /* Invert action performed by optimize_byte_code() */ 2065 /* Invert action performed by optimize_byte_code() */
2068 Lisp_Opaque *opaque = XOPAQUE (f->instructions); 2066 Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2069 2067
2070 Bufbyte * const buffer = 2068 Bufbyte * CONST buffer =
2071 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN); 2069 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2072 Bufbyte *bp = buffer; 2070 Bufbyte *bp = buffer;
2073 2071
2074 const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque); 2072 CONST Opbyte * CONST program = (CONST Opbyte *) OPAQUE_DATA (opaque);
2075 const Opbyte *program_ptr = program; 2073 CONST Opbyte *program_ptr = program;
2076 const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque); 2074 CONST Opbyte * CONST program_end = program_ptr + OPAQUE_SIZE (opaque);
2077 2075
2078 while (program_ptr < program_end) 2076 while (program_ptr < program_end)
2079 { 2077 {
2080 Opcode opcode = (Opcode) READ_UINT_1; 2078 Opcode opcode = (Opcode) READ_UINT_1;
2081 bp += set_charptr_emchar (bp, opcode); 2079 bp += set_charptr_emchar (bp, opcode);
2348 if (!CONSP (tem)) 2346 if (!CONSP (tem))
2349 signal_simple_error ("Invalid lazy-loaded byte code", tem); 2347 signal_simple_error ("Invalid lazy-loaded byte code", tem);
2350 /* v18 or v19 bytecode file. Need to Ebolify. */ 2348 /* v18 or v19 bytecode file. Need to Ebolify. */
2351 if (f->flags.ebolified && VECTORP (XCDR (tem))) 2349 if (f->flags.ebolified && VECTORP (XCDR (tem)))
2352 ebolify_bytecode_constants (XCDR (tem)); 2350 ebolify_bytecode_constants (XCDR (tem));
2353 f->instructions = XCAR (tem); 2351 /* VERY IMPORTANT to purecopy here!!!!!
2354 f->constants = XCDR (tem); 2352 See load_force_doc_string_unwind. */
2353 f->instructions = Fpurecopy (XCAR (tem));
2354 f->constants = Fpurecopy (XCDR (tem));
2355 return function; 2355 return function;
2356 } 2356 }
2357 abort (); 2357 abort ();
2358 return Qnil; /* not reached */ 2358 return Qnil; /* not reached */
2359 } 2359 }
2406 2406
2407 2407
2408 void 2408 void
2409 syms_of_bytecode (void) 2409 syms_of_bytecode (void)
2410 { 2410 {
2411 INIT_LRECORD_IMPLEMENTATION (compiled_function);
2412
2413 deferror (&Qinvalid_byte_code, "invalid-byte-code", 2411 deferror (&Qinvalid_byte_code, "invalid-byte-code",
2414 "Invalid byte code", Qerror); 2412 "Invalid byte code", Qerror);
2415 defsymbol (&Qbyte_code, "byte-code"); 2413 defsymbol (&Qbyte_code, "byte-code");
2416 defsymbol (&Qcompiled_functionp, "compiled-function-p"); 2414 defsymbol (&Qcompiled_functionp, "compiled-function-p");
2417 2415