Mercurial > hg > xemacs-beta

comparison src/bytecode.c @ 442:abe6d1db359e r21-2-36

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-36
author cvs
date Mon, 13 Aug 2007 11:35:02 +0200
parents 8de8e3f6228a
children 576fb035e263
comparison
equal deleted inserted replaced
441:72a7cfa4a488 442:abe6d1db359e
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 <limits.h>
60 58
61 EXFUN (Ffetch_bytecode, 1); 59 EXFUN (Ffetch_bytecode, 1);
62 60
63 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code; 61 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
64 62
214 212
215 213
216 static void invalid_byte_code_error (char *error_message, ...); 214 static void invalid_byte_code_error (char *error_message, ...);
217 215
218 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr, 216 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
219 CONST Opbyte *program_ptr, 217 const Opbyte *program_ptr,
220 Opcode opcode); 218 Opcode opcode);
221 219
222 static Lisp_Object execute_optimized_program (CONST Opbyte *program, 220 static Lisp_Object execute_optimized_program (const Opbyte *program,
223 int stack_depth, 221 int stack_depth,
224 Lisp_Object *constants_data); 222 Lisp_Object *constants_data);
225 223
226 extern Lisp_Object Qand_rest, Qand_optional; 224 extern Lisp_Object Qand_rest, Qand_optional;
227 225
471 in ARGS, and return the result of evaluation. */ 469 in ARGS, and return the result of evaluation. */
472 Lisp_Object 470 Lisp_Object
473 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[]) 471 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[])
474 { 472 {
475 /* This function can GC */ 473 /* This function can GC */
476 Lisp_Object symbol, tail;
477 int speccount = specpdl_depth(); 474 int speccount = specpdl_depth();
478 REGISTER int i = 0; 475 REGISTER int i = 0;
479 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); 476 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
480 int optional = 0; 477 int optional = 0;
481 478
486 /* optimize_compiled_function() guaranteed that f->specpdl_depth is 483 /* optimize_compiled_function() guaranteed that f->specpdl_depth is
487 the required space on the specbinding stack for binding the args 484 the required space on the specbinding stack for binding the args
488 and local variables of fun. So just reserve it once. */ 485 and local variables of fun. So just reserve it once. */
489 SPECPDL_RESERVE (f->specpdl_depth); 486 SPECPDL_RESERVE (f->specpdl_depth);
490 487
491 /* Fmake_byte_code() guaranteed that f->arglist is a valid list 488 {
492 containing only non-constant symbols. */ 489 /* Fmake_byte_code() guaranteed that f->arglist is a valid list
493 LIST_LOOP_3 (symbol, f->arglist, tail) 490 containing only non-constant symbols. */
494 { 491 LIST_LOOP_3 (symbol, f->arglist, tail)
495 if (EQ (symbol, Qand_rest)) 492 {
496 { 493 if (EQ (symbol, Qand_rest))
497 tail = XCDR (tail); 494 {
498 symbol = XCAR (tail); 495 tail = XCDR (tail);
499 SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i])); 496 symbol = XCAR (tail);
500 goto run_code; 497 SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i]));
501 } 498 goto run_code;
502 else if (EQ (symbol, Qand_optional)) 499 }
503 optional = 1; 500 else if (EQ (symbol, Qand_optional))
504 else if (i == nargs && !optional) 501 optional = 1;
505 goto wrong_number_of_arguments; 502 else if (i == nargs && !optional)
506 else 503 goto wrong_number_of_arguments;
507 SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil); 504 else
508 } 505 SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil);
506 }
507 }
509 508
510 if (i < nargs) 509 if (i < nargs)
511 goto wrong_number_of_arguments; 510 goto wrong_number_of_arguments;
512 511
513 run_code: 512 run_code:
594 Don't change the constructs unless you are willing to do 593 Don't change the constructs unless you are willing to do
595 real benchmarking and profiling work -- martin */ 594 real benchmarking and profiling work -- martin */
596 595
597 596
598 static Lisp_Object 597 static Lisp_Object
599 execute_optimized_program (CONST Opbyte *program, 598 execute_optimized_program (const Opbyte *program,
600 int stack_depth, 599 int stack_depth,
601 Lisp_Object *constants_data) 600 Lisp_Object *constants_data)
602 { 601 {
603 /* This function can GC */ 602 /* This function can GC */
604 REGISTER CONST Opbyte *program_ptr = (Opbyte *) program; 603 REGISTER const Opbyte *program_ptr = (Opbyte *) program;
605 REGISTER Lisp_Object *stack_ptr 604 REGISTER Lisp_Object *stack_ptr
606 = alloca_array (Lisp_Object, stack_depth + 1); 605 = alloca_array (Lisp_Object, stack_depth + 1);
607 int speccount = specpdl_depth (); 606 int speccount = specpdl_depth ();
608 struct gcpro gcpro1; 607 struct gcpro gcpro1;
609 608
1219 rarely executed code, to minimize cache misses. 1218 rarely executed code, to minimize cache misses.
1220 1219
1221 Don't make this function static, since then the compiler might inline it. */ 1220 Don't make this function static, since then the compiler might inline it. */
1222 Lisp_Object * 1221 Lisp_Object *
1223 execute_rare_opcode (Lisp_Object *stack_ptr, 1222 execute_rare_opcode (Lisp_Object *stack_ptr,
1224 CONST Opbyte *program_ptr, 1223 const Opbyte *program_ptr,
1225 Opcode opcode) 1224 Opcode opcode)
1226 { 1225 {
1227 switch (opcode) 1226 switch (opcode)
1228 { 1227 {
1229 1228
1489 va_list args; 1488 va_list args;
1490 char *buf = alloca_array (char, strlen (error_message) + 128); 1489 char *buf = alloca_array (char, strlen (error_message) + 128);
1491 1490
1492 sprintf (buf, "%s", error_message); 1491 sprintf (buf, "%s", error_message);
1493 va_start (args, error_message); 1492 va_start (args, error_message);
1494 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (buf), Qnil, -1, 1493 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (buf), Qnil, -1,
1495 args); 1494 args);
1496 va_end (args); 1495 va_end (args);
1497 1496
1498 signal_error (Qinvalid_byte_code, list1 (obj)); 1497 signal_error (Qinvalid_byte_code, list1 (obj));
1499 } 1498 }
1605 static void 1604 static void
1606 optimize_byte_code (/* in */ 1605 optimize_byte_code (/* in */
1607 Lisp_Object instructions, 1606 Lisp_Object instructions,
1608 Lisp_Object constants, 1607 Lisp_Object constants,
1609 /* out */ 1608 /* out */
1610 Opbyte * CONST program, 1609 Opbyte * const program,
1611 int * CONST program_length, 1610 int * const program_length,
1612 int * CONST varbind_count) 1611 int * const varbind_count)
1613 { 1612 {
1614 size_t instructions_length = XSTRING_LENGTH (instructions); 1613 size_t instructions_length = XSTRING_LENGTH (instructions);
1615 size_t comfy_size = 2 * instructions_length; 1614 size_t comfy_size = 2 * instructions_length;
1616 1615
1617 int * CONST icounts = alloca_array (int, comfy_size); 1616 int * const icounts = alloca_array (int, comfy_size);
1618 int * icounts_ptr = icounts; 1617 int * icounts_ptr = icounts;
1619 1618
1620 /* We maintain a table of jumps in the source code. */ 1619 /* We maintain a table of jumps in the source code. */
1621 struct jump 1620 struct jump
1622 { 1621 {
1623 int from; 1622 int from;
1624 int to; 1623 int to;
1625 }; 1624 };
1626 struct jump * CONST jumps = alloca_array (struct jump, comfy_size); 1625 struct jump * const jumps = alloca_array (struct jump, comfy_size);
1627 struct jump *jumps_ptr = jumps; 1626 struct jump *jumps_ptr = jumps;
1628 1627
1629 Opbyte *program_ptr = program; 1628 Opbyte *program_ptr = program;
1630 1629
1631 CONST Bufbyte *ptr = XSTRING_DATA (instructions); 1630 const Bufbyte *ptr = XSTRING_DATA (instructions);
1632 CONST Bufbyte * CONST end = ptr + instructions_length; 1631 const Bufbyte * const end = ptr + instructions_length;
1633 1632
1634 *varbind_count = 0; 1633 *varbind_count = 0;
1635 1634
1636 while (ptr < end) 1635 while (ptr < end)
1637 { 1636 {
2067 2066
2068 { 2067 {
2069 /* Invert action performed by optimize_byte_code() */ 2068 /* Invert action performed by optimize_byte_code() */
2070 Lisp_Opaque *opaque = XOPAQUE (f->instructions); 2069 Lisp_Opaque *opaque = XOPAQUE (f->instructions);
2071 2070
2072 Bufbyte * CONST buffer = 2071 Bufbyte * const buffer =
2073 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN); 2072 alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
2074 Bufbyte *bp = buffer; 2073 Bufbyte *bp = buffer;
2075 2074
2076 CONST Opbyte * CONST program = (CONST Opbyte *) OPAQUE_DATA (opaque); 2075 const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
2077 CONST Opbyte *program_ptr = program; 2076 const Opbyte *program_ptr = program;
2078 CONST Opbyte * CONST program_end = program_ptr + OPAQUE_SIZE (opaque); 2077 const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);
2079 2078
2080 while (program_ptr < program_end) 2079 while (program_ptr < program_end)
2081 { 2080 {
2082 Opcode opcode = (Opcode) READ_UINT_1; 2081 Opcode opcode = (Opcode) READ_UINT_1;
2083 bp += set_charptr_emchar (bp, opcode); 2082 bp += set_charptr_emchar (bp, opcode);
2408 2407
2409 2408
2410 void 2409 void
2411 syms_of_bytecode (void) 2410 syms_of_bytecode (void)
2412 { 2411 {
2413 deferror (&Qinvalid_byte_code, "invalid-byte-code", 2412 INIT_LRECORD_IMPLEMENTATION (compiled_function);
2414 "Invalid byte code", Qerror); 2413
2414 DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state);
2415 defsymbol (&Qbyte_code, "byte-code"); 2415 defsymbol (&Qbyte_code, "byte-code");
2416 defsymbol (&Qcompiled_functionp, "compiled-function-p"); 2416 defsymbol (&Qcompiled_functionp, "compiled-function-p");
2417 2417
2418 DEFSUBR (Fbyte_code); 2418 DEFSUBR (Fbyte_code);
2419 DEFSUBR (Ffetch_bytecode); 2419 DEFSUBR (Ffetch_bytecode);