commit: add more byte-code assertions and better failure output
Ben Wing
ben at xemacs.org
Wed Feb 3 09:03:27 EST 2010
changeset: 4921:17362f371cc2
parent: 4914:1628e3b9601a
user: Ben Wing <ben at xemacs.org>
date: Wed Feb 03 08:01:55 2010 -0600
files: src/ChangeLog src/alloc.c src/bytecode-ops.h src/bytecode.c src/bytecode.h src/emacs.c src/eval.c src/gc.c src/lisp.h src/lread.c src/symbols.c src/symeval.h src/symsinit.h
description:
add more byte-code assertions and better failure output
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-02-03 Ben Wing <ben at xemacs.org>
* alloc.c (Fmake_byte_code):
* bytecode.h:
* lisp.h:
* lread.c:
* lread.c (readevalloop):
* lread.c (Fread):
* lread.c (Fread_from_string):
* lread.c (read_list_conser):
* lread.c (read_list):
* lread.c (vars_of_lread):
* symbols.c:
* symbols.c (Fdefine_function):
Turn on the "compiled-function annotation hack". Implement it
properly by hooking into Fdefalias(). Note in the docstring to
`defalias' that we do this. Remove some old broken code and
change code that implemented the old kludgy way of hooking into
the Lisp reader into bracketed by `#ifdef
COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY', which is not enabled.
Also enable byte-code metering when DEBUG_XEMACS -- this is a form
of profiling for computing histograms of which sequences of two
bytecodes are used most often.
* bytecode-ops.h:
* bytecode-ops.h (OPCODE):
New file. Extract out all the opcodes and declare them using
OPCODE(), a bit like frame slots and such. This way the file can
be included multiple times if necessary to iterate multiple times
over the byte opcodes.
* bytecode.c:
* bytecode.c (NUM_REMEMBERED_BYTE_OPS):
* bytecode.c (OPCODE):
* bytecode.c (assert_failed_with_remembered_ops):
* bytecode.c (READ_UINT_2):
* bytecode.c (READ_INT_1):
* bytecode.c (READ_INT_2):
* bytecode.c (PEEK_INT_1):
* bytecode.c (PEEK_INT_2):
* bytecode.c (JUMP_RELATIVE):
* bytecode.c (JUMP_NEXT):
* bytecode.c (PUSH):
* bytecode.c (POP_WITH_MULTIPLE_VALUES):
* bytecode.c (DISCARD):
* bytecode.c (UNUSED):
* bytecode.c (optimize_byte_code):
* bytecode.c (optimize_compiled_function):
* bytecode.c (Fbyte_code):
* bytecode.c (vars_of_bytecode):
* bytecode.c (init_opcode_table_multi_op):
* bytecode.c (reinit_vars_of_bytecode):
* emacs.c (main_1):
* eval.c (funcall_compiled_function):
* symsinit.h:
Any time we change either the instruction pointer or the stack
pointer, assert that we're going to move it to a valid location.
This should catch failures right when they occur rather than
sometime later. This requires that we pass in another couple of
parameters into some functions (only with error-checking enabled,
see below).
Also keep track, using a circular queue, of the last 100 byte
opcodes seen, and when we hit an assert failure during byte-code
execution, output the contents of the queue in a nice readable
fashion. This requires that bytecode-ops.h be included a second
time so that a table mapping opcodes to the name of their operation
can be constructed. This table is constructed in new function
reinit_vars_of_bytecode().
Everything in the last two paras happens only when
ERROR_CHECK_BYTE_CODE.
Add some longish comments describing how the arrays that hold the
stack and instructions, and the pointers used to access them, work.
* gc.c:
Import some code from my `latest-fix' workspace to mark the
staticpro's in order from lowest to highest, rather than highest to
lowest, so it's easier to debug when something goes wrong.
* lisp.h (abort_with_message): Renamed from abort_with_msg().
* symbols.c (defsymbol_massage_name_1):
* symbols.c (defsymbol_nodump):
* symbols.c (defsymbol):
* symbols.c (defkeyword):
* symeval.h (DEFVAR_SYMVAL_FWD_OBJECT):
Make the various calls to staticpro() instead call staticpro_1(),
passing in the name of the C var being staticpro'ed, so that it
shows up in staticpro_names. Otherwise staticpro_names just has
1000+ copies of the word `location'.
diff -r 1628e3b9601a -r 17362f371cc2 src/ChangeLog
--- a/src/ChangeLog Tue Feb 02 15:19:15 2010 -0600
+++ b/src/ChangeLog Wed Feb 03 08:01:55 2010 -0600
@@ -1,3 +1,97 @@
+2010-02-03 Ben Wing <ben at xemacs.org>
+
+ * alloc.c (Fmake_byte_code):
+ * bytecode.h:
+ * lisp.h:
+ * lread.c:
+ * lread.c (readevalloop):
+ * lread.c (Fread):
+ * lread.c (Fread_from_string):
+ * lread.c (read_list_conser):
+ * lread.c (read_list):
+ * lread.c (vars_of_lread):
+ * symbols.c:
+ * symbols.c (Fdefine_function):
+ Turn on the "compiled-function annotation hack". Implement it
+ properly by hooking into Fdefalias(). Note in the docstring to
+ `defalias' that we do this. Remove some old broken code and
+ change code that implemented the old kludgy way of hooking into
+ the Lisp reader into bracketed by `#ifdef
+ COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY', which is not enabled.
+
+ Also enable byte-code metering when DEBUG_XEMACS -- this is a form
+ of profiling for computing histograms of which sequences of two
+ bytecodes are used most often.
+
+ * bytecode-ops.h:
+ * bytecode-ops.h (OPCODE):
+ New file. Extract out all the opcodes and declare them using
+ OPCODE(), a bit like frame slots and such. This way the file can
+ be included multiple times if necessary to iterate multiple times
+ over the byte opcodes.
+
+ * bytecode.c:
+ * bytecode.c (NUM_REMEMBERED_BYTE_OPS):
+ * bytecode.c (OPCODE):
+ * bytecode.c (assert_failed_with_remembered_ops):
+ * bytecode.c (READ_UINT_2):
+ * bytecode.c (READ_INT_1):
+ * bytecode.c (READ_INT_2):
+ * bytecode.c (PEEK_INT_1):
+ * bytecode.c (PEEK_INT_2):
+ * bytecode.c (JUMP_RELATIVE):
+ * bytecode.c (JUMP_NEXT):
+ * bytecode.c (PUSH):
+ * bytecode.c (POP_WITH_MULTIPLE_VALUES):
+ * bytecode.c (DISCARD):
+ * bytecode.c (UNUSED):
+ * bytecode.c (optimize_byte_code):
+ * bytecode.c (optimize_compiled_function):
+ * bytecode.c (Fbyte_code):
+ * bytecode.c (vars_of_bytecode):
+ * bytecode.c (init_opcode_table_multi_op):
+ * bytecode.c (reinit_vars_of_bytecode):
+ * emacs.c (main_1):
+ * eval.c (funcall_compiled_function):
+ * symsinit.h:
+ Any time we change either the instruction pointer or the stack
+ pointer, assert that we're going to move it to a valid location.
+ This should catch failures right when they occur rather than
+ sometime later. This requires that we pass in another couple of
+ parameters into some functions (only with error-checking enabled,
+ see below).
+
+ Also keep track, using a circular queue, of the last 100 byte
+ opcodes seen, and when we hit an assert failure during byte-code
+ execution, output the contents of the queue in a nice readable
+ fashion. This requires that bytecode-ops.h be included a second
+ time so that a table mapping opcodes to the name of their operation
+ can be constructed. This table is constructed in new function
+ reinit_vars_of_bytecode().
+
+ Everything in the last two paras happens only when
+ ERROR_CHECK_BYTE_CODE.
+
+ Add some longish comments describing how the arrays that hold the
+ stack and instructions, and the pointers used to access them, work.
+
+ * gc.c:
+ Import some code from my `latest-fix' workspace to mark the
+ staticpro's in order from lowest to highest, rather than highest to
+ lowest, so it's easier to debug when something goes wrong.
+
+ * lisp.h (abort_with_message): Renamed from abort_with_msg().
+
+ * symbols.c (defsymbol_massage_name_1):
+ * symbols.c (defsymbol_nodump):
+ * symbols.c (defsymbol):
+ * symbols.c (defkeyword):
+ * symeval.h (DEFVAR_SYMVAL_FWD_OBJECT):
+ Make the various calls to staticpro() instead call staticpro_1(),
+ passing in the name of the C var being staticpro'ed, so that it
+ shows up in staticpro_names. Otherwise staticpro_names just has
+ 1000+ copies of the word `location'.
+
2010-02-02 Ben Wing <ben at xemacs.org>
* bytecode.c (execute_rare_opcode):
diff -r 1628e3b9601a -r 17362f371cc2 src/alloc.c
--- a/src/alloc.c Tue Feb 02 15:19:15 2010 -0600
+++ b/src/alloc.c Wed Feb 03 08:01:55 2010 -0600
@@ -1930,19 +1930,12 @@
f->stack_depth = (unsigned short) XINT (stack_depth);
#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY
if (!NILP (Vcurrent_compiled_function_annotation))
- f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
- else if (!NILP (Vload_file_name_internal_the_purecopy))
- f->annotated = Vload_file_name_internal_the_purecopy;
- else if (!NILP (Vload_file_name_internal))
- {
- struct gcpro gcpro1;
- GCPRO1 (fun); /* don't let fun get reaped */
- Vload_file_name_internal_the_purecopy =
- Ffile_name_nondirectory (Vload_file_name_internal);
- f->annotated = Vload_file_name_internal_the_purecopy;
- UNGCPRO;
- }
+ f->annotated = Vcurrent_compiled_function_annotation;
+ else
+#endif /* COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY */
+ f->annotated = Vload_file_name_internal;
#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
/* doc_string may be nil, string, int, or a cons (string . int).
diff -r 1628e3b9601a -r 17362f371cc2 src/bytecode-ops.h
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/bytecode-ops.h Wed Feb 03 08:01:55 2010 -0600
@@ -0,0 +1,185 @@
+/* Execution of byte code produced by bytecomp.el.
+ Implementation of compiled-function objects.
+ Copyright (C) 1992, 1993 Free Software Foundation, Inc.
+ Copyright (C) 1995, 2002, 2010 Ben Wing.
+
+This file is part of XEmacs.
+
+XEmacs is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2, or (at your option) any
+later version.
+
+XEmacs is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with XEmacs; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* Synched up with: Mule 2.0, FSF 19.30. */
+
+/* There is more than one place in bytecode.c that may want to do something
+ with the list of all the opcodes. To handle this, we extract them into
+ a separate file that can get included after defining OPCODE(sym, val)
+ appropriately. No need to undefine OPCODE; that happens automatically.
+*/
+
+ OPCODE (varref, 010)
+ OPCODE (varset, 020)
+ OPCODE (varbind, 030)
+ OPCODE (call, 040)
+ OPCODE (unbind, 050)
+
+ OPCODE (nth, 070)
+ OPCODE (symbolp, 071)
+ OPCODE (consp, 072)
+ OPCODE (stringp, 073)
+ OPCODE (listp, 074)
+ OPCODE (old_eq, 075)
+ OPCODE (old_memq, 076)
+ OPCODE (not, 077)
+ OPCODE (car, 0100)
+ OPCODE (cdr, 0101)
+ OPCODE (cons, 0102)
+ OPCODE (list1, 0103)
+ OPCODE (list2, 0104)
+ OPCODE (list3, 0105)
+ OPCODE (list4, 0106)
+ OPCODE (length, 0107)
+ OPCODE (aref, 0110)
+ OPCODE (aset, 0111)
+ OPCODE (symbol_value, 0112)
+ OPCODE (symbol_function, 0113)
+ OPCODE (set, 0114)
+ OPCODE (fset, 0115)
+ OPCODE (get, 0116)
+ OPCODE (substring, 0117)
+ OPCODE (concat2, 0120)
+ OPCODE (concat3, 0121)
+ OPCODE (concat4, 0122)
+ OPCODE (sub1, 0123)
+ OPCODE (add1, 0124)
+ OPCODE (eqlsign, 0125)
+ OPCODE (gtr, 0126)
+ OPCODE (lss, 0127)
+ OPCODE (leq, 0130)
+ OPCODE (geq, 0131)
+ OPCODE (diff, 0132)
+ OPCODE (negate, 0133)
+ OPCODE (plus, 0134)
+ OPCODE (max, 0135)
+ OPCODE (min, 0136)
+ OPCODE (mult, 0137)
+
+ OPCODE (point, 0140)
+ OPCODE (eq, 0141) /* was Bmark, but no longer
+ generated as of v18 */
+ OPCODE (goto_char, 0142)
+ OPCODE (insert, 0143)
+ OPCODE (point_max, 0144)
+ OPCODE (point_min, 0145)
+ OPCODE (char_after, 0146)
+ OPCODE (following_char, 0147)
+ OPCODE (preceding_char, 0150)
+ OPCODE (current_column, 0151)
+ OPCODE (indent_to, 0152)
+ OPCODE (equal, 0153) /* was Bscan_buffer, but no
+ longer generated as of
+ v18 */
+ OPCODE (eolp, 0154)
+ OPCODE (eobp, 0155)
+ OPCODE (bolp, 0156)
+ OPCODE (bobp, 0157)
+ OPCODE (current_buffer, 0160)
+ OPCODE (set_buffer, 0161)
+ OPCODE (save_current_buffer, 0162) /* was Bread_char, but no
+ longer generated as of
+ v19 */
+ OPCODE (memq, 0163) /* was Bset_mark, but no
+ longer generated as of
+ v18 */
+ OPCODE (interactive_p, 0164) /* Needed since interactive-p
+ takes unevalled args */
+ OPCODE (forward_char, 0165)
+ OPCODE (forward_word, 0166)
+ OPCODE (skip_chars_forward, 0167)
+ OPCODE (skip_chars_backward, 0170)
+ OPCODE (forward_line, 0171)
+ OPCODE (char_syntax, 0172)
+ OPCODE (buffer_substring, 0173)
+ OPCODE (delete_region, 0174)
+ OPCODE (narrow_to_region, 0175)
+ OPCODE (widen, 0176)
+ OPCODE (end_of_line, 0177)
+
+ OPCODE (constant2, 0201)
+ OPCODE (goto, 0202)
+ OPCODE (gotoifnil, 0203)
+ OPCODE (gotoifnonnil, 0204)
+ OPCODE (gotoifnilelsepop, 0205)
+ OPCODE (gotoifnonnilelsepop, 0206)
+ OPCODE (return, 0207)
+ OPCODE (discard, 0210)
+ OPCODE (dup, 0211)
+
+ OPCODE (save_excursion, 0212)
+ OPCODE (save_window_excursion, 0213)
+ OPCODE (save_restriction, 0214)
+ OPCODE (catch, 0215)
+
+ OPCODE (unwind_protect, 0216)
+ OPCODE (condition_case, 0217)
+ OPCODE (temp_output_buffer_setup, 0220)
+ OPCODE (temp_output_buffer_show, 0221)
+
+ OPCODE (unbind_all, 0222)
+
+ OPCODE (set_marker, 0223)
+ OPCODE (match_beginning, 0224)
+ OPCODE (match_end, 0225)
+ OPCODE (upcase, 0226)
+ OPCODE (downcase, 0227)
+
+ OPCODE (string_equal, 0230)
+ OPCODE (string_lessp, 0231)
+ OPCODE (old_equal, 0232)
+ OPCODE (nthcdr, 0233)
+ OPCODE (elt, 0234)
+ OPCODE (old_member, 0235)
+ OPCODE (old_assq, 0236)
+ OPCODE (nreverse, 0237)
+ OPCODE (setcar, 0240)
+ OPCODE (setcdr, 0241)
+ OPCODE (car_safe, 0242)
+ OPCODE (cdr_safe, 0243)
+ OPCODE (nconc, 0244)
+ OPCODE (quo, 0245)
+ OPCODE (rem, 0246)
+ OPCODE (numberp, 0247)
+ OPCODE (fixnump, 0250) /* Was Bintegerp. */
+
+ OPCODE (Rgoto, 0252)
+ OPCODE (Rgotoifnil, 0253)
+ OPCODE (Rgotoifnonnil, 0254)
+ OPCODE (Rgotoifnilelsepop, 0255)
+ OPCODE (Rgotoifnonnilelsepop, 0256)
+
+ OPCODE (listN, 0257)
+ OPCODE (concatN, 0260)
+ OPCODE (insertN, 0261)
+
+ OPCODE (bind_multiple_value_limits, 0262) /* New in 21.5. */
+ OPCODE (multiple_value_list_internal, 0263) /* New in 21.5. */
+ OPCODE (multiple_value_call, 0264) /* New in 21.5. */
+ OPCODE (throw, 0265) /* New in 21.5. */
+
+ OPCODE (member, 0266) /* new in v20 */
+ OPCODE (assq, 0267) /* new in v20 */
+
+ OPCODE (constant, 0300)
+
+#undef OPCODE
diff -r 1628e3b9601a -r 17362f371cc2 src/bytecode.c
--- a/src/bytecode.c Tue Feb 02 15:19:15 2010 -0600
+++ b/src/bytecode.c Wed Feb 03 08:01:55 2010 -0600
@@ -57,6 +57,8 @@
#include "opaque.h"
#include "syntax.h"
#include "window.h"
+
+#define NUM_REMEMBERED_BYTE_OPS 100
#ifdef NEW_GC
static Lisp_Object
@@ -101,169 +103,104 @@
Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
+
enum Opcode /* Byte codes */
{
- Bvarref = 010,
- Bvarset = 020,
- Bvarbind = 030,
- Bcall = 040,
- Bunbind = 050,
-
- Bnth = 070,
- Bsymbolp = 071,
- Bconsp = 072,
- Bstringp = 073,
- Blistp = 074,
- Bold_eq = 075,
- Bold_memq = 076,
- Bnot = 077,
- Bcar = 0100,
- Bcdr = 0101,
- Bcons = 0102,
- Blist1 = 0103,
- Blist2 = 0104,
- Blist3 = 0105,
- Blist4 = 0106,
- Blength = 0107,
- Baref = 0110,
- Baset = 0111,
- Bsymbol_value = 0112,
- Bsymbol_function = 0113,
- Bset = 0114,
- Bfset = 0115,
- Bget = 0116,
- Bsubstring = 0117,
- Bconcat2 = 0120,
- Bconcat3 = 0121,
- Bconcat4 = 0122,
- Bsub1 = 0123,
- Badd1 = 0124,
- Beqlsign = 0125,
- Bgtr = 0126,
- Blss = 0127,
- Bleq = 0130,
- Bgeq = 0131,
- Bdiff = 0132,
- Bnegate = 0133,
- Bplus = 0134,
- Bmax = 0135,
- Bmin = 0136,
- Bmult = 0137,
-
- Bpoint = 0140,
- Beq = 0141, /* was Bmark,
- but no longer generated as of v18 */
- Bgoto_char = 0142,
- Binsert = 0143,
- Bpoint_max = 0144,
- Bpoint_min = 0145,
- Bchar_after = 0146,
- Bfollowing_char = 0147,
- Bpreceding_char = 0150,
- Bcurrent_column = 0151,
- Bindent_to = 0152,
- Bequal = 0153, /* was Bscan_buffer,
- but no longer generated as of v18 */
- Beolp = 0154,
- Beobp = 0155,
- Bbolp = 0156,
- Bbobp = 0157,
- Bcurrent_buffer = 0160,
- Bset_buffer = 0161,
- Bsave_current_buffer = 0162, /* was Bread_char,
- but no longer generated as of v19 */
- Bmemq = 0163, /* was Bset_mark,
- but no longer generated as of v18 */
- Binteractive_p = 0164, /* Needed since interactive-p takes
- unevalled args */
- Bforward_char = 0165,
- Bforward_word = 0166,
- Bskip_chars_forward = 0167,
- Bskip_chars_backward = 0170,
- Bforward_line = 0171,
- Bchar_syntax = 0172,
- Bbuffer_substring = 0173,
- Bdelete_region = 0174,
- Bnarrow_to_region = 0175,
- Bwiden = 0176,
- Bend_of_line = 0177,
-
- Bconstant2 = 0201,
- Bgoto = 0202,
- Bgotoifnil = 0203,
- Bgotoifnonnil = 0204,
- Bgotoifnilelsepop = 0205,
- Bgotoifnonnilelsepop = 0206,
- Breturn = 0207,
- Bdiscard = 0210,
- Bdup = 0211,
-
- Bsave_excursion = 0212,
- Bsave_window_excursion= 0213,
- Bsave_restriction = 0214,
- Bcatch = 0215,
-
- Bunwind_protect = 0216,
- Bcondition_case = 0217,
- Btemp_output_buffer_setup = 0220,
- Btemp_output_buffer_show = 0221,
-
- Bunbind_all = 0222,
-
- Bset_marker = 0223,
- Bmatch_beginning = 0224,
- Bmatch_end = 0225,
- Bupcase = 0226,
- Bdowncase = 0227,
-
- Bstring_equal = 0230,
- Bstring_lessp = 0231,
- Bold_equal = 0232,
- Bnthcdr = 0233,
- Belt = 0234,
- Bold_member = 0235,
- Bold_assq = 0236,
- Bnreverse = 0237,
- Bsetcar = 0240,
- Bsetcdr = 0241,
- Bcar_safe = 0242,
- Bcdr_safe = 0243,
- Bnconc = 0244,
- Bquo = 0245,
- Brem = 0246,
- Bnumberp = 0247,
- Bfixnump = 0250, /* Was Bintegerp. */
-
- BRgoto = 0252,
- BRgotoifnil = 0253,
- BRgotoifnonnil = 0254,
- BRgotoifnilelsepop = 0255,
- BRgotoifnonnilelsepop = 0256,
-
- BlistN = 0257,
- BconcatN = 0260,
- BinsertN = 0261,
-
- Bbind_multiple_value_limits = 0262, /* New in 21.5. */
- Bmultiple_value_list_internal = 0263, /* New in 21.5. */
- Bmultiple_value_call = 0264, /* New in 21.5. */
- Bthrow = 0265, /* New in 21.5. */
-
- Bmember = 0266, /* new in v20 */
- Bassq = 0267, /* new in v20 */
-
- Bconstant = 0300
+#define OPCODE(sym, val) B##sym = val,
+#include "bytecode-ops.h"
};
typedef enum Opcode Opcode;
-
Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
+#ifdef ERROR_CHECK_BYTE_CODE
+ Lisp_Object *stack_beg,
+ Lisp_Object *stack_end,
+#endif /* ERROR_CHECK_BYTE_CODE */
const Opbyte *program_ptr,
Opcode opcode);
-/* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
- This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
-/* #define BYTE_CODE_METER */
+#ifndef ERROR_CHECK_BYTE_CODE
+
+# define bytecode_assert(x) disabled_assert (x)
+# define bytecode_assert_with_message(x, msg) disabled_assert(x)
+# define bytecode_abort_with_message(msg) abort_with_message (msg)
+
+#else /* ERROR_CHECK_BYTE_CODE */
+
+# define bytecode_assert(x) \
+ ((x) ? (void) 0 : assert_failed_with_remembered_ops (__FILE__, __LINE__, #x))
+# define bytecode_assert_with_message(x, msg) \
+ ((x) ? (void) 0 : assert_failed_with_remembered_ops (__FILE__, __LINE__, msg))
+# define bytecode_abort_with_message(msg) \
+ assert_failed_with_remembered_ops (__FILE__, __LINE__, msg)
+
+/* Table mapping opcodes to their names. This handles opcodes like
+ Bvarref+7, but it doesn't list any of the Bconstant+N opcodes; those
+ are handled specially. */
+Ascbyte *opcode_name_table[256];
+
+/* Circular queue remembering the most recent operations. */
+Opcode remembered_ops[NUM_REMEMBERED_BYTE_OPS];
+int remembered_op_next_pos, num_remembered;
+
+static void
+remember_operation (Opcode op)
+{
+ remembered_ops[remembered_op_next_pos] = op;
+ remembered_op_next_pos =
+ (remembered_op_next_pos + 1) % NUM_REMEMBERED_BYTE_OPS;
+ if (num_remembered < NUM_REMEMBERED_BYTE_OPS)
+ num_remembered++;
+}
+
+static void
+assert_failed_with_remembered_ops (const Ascbyte *file, int line,
+ Ascbyte *msg_to_abort_with)
+{
+ Ascbyte *msg =
+ alloca_array (Ascbyte,
+ NUM_REMEMBERED_BYTE_OPS*50 + strlen (msg_to_abort_with));
+ int i;
+
+ if (msg_to_abort_with)
+ strcpy (msg, msg_to_abort_with);
+ strcat (msg, "\n\nRecent bytecodes, oldest first:\n\n");
+
+ for (i = 0; i < num_remembered; i++)
+ {
+ Ascbyte msg2[50];
+ int pos;
+ Opcode op;
+
+ sprintf (msg2, "%5d: ", i - num_remembered + 1);
+ strcat (msg, msg2);
+ pos = (remembered_op_next_pos + NUM_REMEMBERED_BYTE_OPS +
+ i - num_remembered) % NUM_REMEMBERED_BYTE_OPS;
+ op = remembered_ops[pos];
+ if (op >= Bconstant)
+ {
+ sprintf (msg2, "constant+%d", op - Bconstant);
+ strcat (msg, msg2);
+ }
+ else
+ {
+ Ascbyte *opname = opcode_name_table[op];
+ if (!opname)
+ {
+ stderr_out ("Internal error! NULL pointer in opcode_name_table, opcode %d\n", op);
+ strcat (msg, "NULL");
+ }
+ else
+ strcat (msg, opname);
+ }
+ sprintf (msg2, " (%d)\n", op);
+ strcat (msg, msg2);
+ }
+
+ assert_failed (file, line, msg);
+}
+
+#endif /* ERROR_CHECK_BYTE_CODE */
#ifdef BYTE_CODE_METER
@@ -619,72 +556,127 @@
}
+
+/*********************** The instruction array *********************/
+
+/* Check that there are at least LEN elements left in the end of the
+ instruction array before fetching them. Note that we allow for
+ PROGRAM_PTR == PROGRAM_END after the fetch -- that means there are
+ no more elements to fetch next time around, but we might exit before
+ next time comes.
+
+ When checking the destination if jumps, however, we don't allow
+ PROGRAM_PTR to equal PROGRAM_END, since we will always be fetching
+ another instruction after the jump. */
+
+#define CHECK_OPCODE_SPACE(len) \
+ bytecode_assert (program_ptr + len <= program_end)
+
/* Read next uint8 from the instruction stream. */
-#define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
+#define READ_UINT_1 \
+ (CHECK_OPCODE_SPACE (1), (unsigned int) (unsigned char) *program_ptr++)
/* Read next uint16 from the instruction stream. */
#define READ_UINT_2 \
- (program_ptr += 2, \
+ (CHECK_OPCODE_SPACE (2), \
+ program_ptr += 2, \
(((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \
((unsigned int) (unsigned char) program_ptr[-2])))
/* Read next int8 from the instruction stream. */
-#define READ_INT_1 ((int) (signed char) *program_ptr++)
+#define READ_INT_1 \
+ (CHECK_OPCODE_SPACE (1), (int) (signed char) *program_ptr++)
/* Read next int16 from the instruction stream. */
#define READ_INT_2 \
- (program_ptr += 2, \
+ (CHECK_OPCODE_SPACE (2), \
+ program_ptr += 2, \
(((int) ( signed char) program_ptr[-1]) * 256 + \
((int) (unsigned char) program_ptr[-2])))
/* Read next int8 from instruction stream; don't advance program_pointer */
-#define PEEK_INT_1 ((int) (signed char) program_ptr[0])
+#define PEEK_INT_1 \
+ (CHECK_OPCODE_SPACE (1), (int) (signed char) program_ptr[0])
/* Read next int16 from instruction stream; don't advance program_pointer */
#define PEEK_INT_2 \
- ((((int) ( signed char) program_ptr[1]) * 256) | \
+ (CHECK_OPCODE_SPACE (2), \
+ (((int) ( signed char) program_ptr[1]) * 256) | \
((int) (unsigned char) program_ptr[0]))
/* Do relative jumps from the current location.
We only do a QUIT if we jump backwards, for efficiency.
No infloops without backward jumps! */
-#define JUMP_RELATIVE(jump) do { \
- int JR_jump = (jump); \
- if (JR_jump < 0) QUIT; \
- program_ptr += JR_jump; \
+#define JUMP_RELATIVE(jump) do { \
+ int _JR_jump = (jump); \
+ if (_JR_jump < 0) QUIT; \
+ /* Check that where we're going to is in range. Note that we don't use \
+ CHECK_OPCODE_SPACE() -- that only checks the end, and it allows \
+ program_ptr == program_end, which we don't allow. */ \
+ bytecode_assert (program_ptr + _JR_jump >= program && \
+ program_ptr + _JR_jump < program_end); \
+ program_ptr += _JR_jump; \
} while (0)
#define JUMP JUMP_RELATIVE (PEEK_INT_2)
#define JUMPR JUMP_RELATIVE (PEEK_INT_1)
-#define JUMP_NEXT ((void) (program_ptr += 2))
-#define JUMPR_NEXT ((void) (program_ptr += 1))
+#define JUMP_NEXT (CHECK_OPCODE_SPACE (2), (void) (program_ptr += 2))
+#define JUMPR_NEXT (CHECK_OPCODE_SPACE (1), (void) (program_ptr += 1))
+
+/*********************** The stack array *********************/
+
+/* NOTE: The stack array doesn't work quite like you'd expect.
+
+ STACK_PTR points to the value on the top of the stack. Popping a value
+ fetches the value from the STACK_PTR and then decrements it. Pushing a
+ value first increments it, then writes the new value. STACK_PTR -
+ STACK_BEG is the number of elements on the stack.
+
+ This means that when STACK_PTR == STACK_BEG, the stack is empty, and
+ the space at STACK_BEG is never written to -- the first push will write
+ into the space directly after STACK_BEG. This is why the call to
+ alloca_array() below has a count of `stack_depth + 1', and why
+ we GCPRO1 (stack_ptr[1]) -- the value at stack_ptr[0] is unused and
+ uninitialized.
+
+ Also, STACK_END actually points to the last usable storage location,
+ and does not point past the end, like you'd expect. */
+
+#define CHECK_STACKPTR_OFFSET(len) \
+ bytecode_assert (stack_ptr + (len) >= stack_beg && \
+ stack_ptr + (len) <= stack_end)
/* Push x onto the execution stack. */
-#define PUSH(x) (*++stack_ptr = (x))
+#define PUSH(x) (CHECK_STACKPTR_OFFSET (1), *++stack_ptr = (x))
/* Pop a value, which may be multiple, off the execution stack. */
-#define POP_WITH_MULTIPLE_VALUES (*stack_ptr--)
+#define POP_WITH_MULTIPLE_VALUES (CHECK_STACKPTR_OFFSET (-1), *stack_ptr--)
/* Pop a value off the execution stack, treating multiple values as single. */
#define POP (IGNORE_MULTIPLE_VALUES (POP_WITH_MULTIPLE_VALUES))
-#define DISCARD_PRESERVING_MULTIPLE_VALUES(n) (stack_ptr -= (n))
+/* ..._UNSAFE() means it evaluates its argument more than once. */
+#define DISCARD_PRESERVING_MULTIPLE_VALUES_UNSAFE(n) \
+ (CHECK_STACKPTR_OFFSET (-(n)), stack_ptr -= (n))
/* Discard n values from the execution stack. */
#define DISCARD(n) do { \
+ int _discard_n = (n); \
if (1 != multiple_value_current_limit) \
{ \
- int i, en = n; \
- for (i = 0; i < en; i++) \
+ int i; \
+ for (i = 0; i < _discard_n; i++) \
{ \
+ CHECK_STACKPTR_OFFSET (-1); \
*stack_ptr = ignore_multiple_values (*stack_ptr); \
stack_ptr--; \
} \
} \
else \
{ \
- stack_ptr -= (n); \
+ CHECK_STACKPTR_OFFSET (-_discard_n); \
+ stack_ptr -= _discard_n; \
} \
} while (0)
@@ -705,6 +697,7 @@
/* See comment before the big switch in execute_optimized_program(). */
#define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg)
+
/* The actual interpreter for byte code.
This function has been seriously optimized for performance.
Don't change the constructs unless you are willing to do
@@ -713,11 +706,18 @@
Lisp_Object
execute_optimized_program (const Opbyte *program,
+#ifdef ERROR_CHECK_BYTE_CODE
+ Elemcount program_length,
+#endif
int stack_depth,
Lisp_Object *constants_data)
{
/* This function can GC */
REGISTER const Opbyte *program_ptr = (Opbyte *) program;
+#ifdef ERROR_CHECK_BYTE_CODE
+ const Opbyte *program_end = program_ptr + program_length;
+#endif
+ /* See comment above explaining the `+ 1' */
Lisp_Object *stack_beg = alloca_array (Lisp_Object, stack_depth + 1);
REGISTER Lisp_Object *stack_ptr = stack_beg;
int speccount = specpdl_depth ();
@@ -759,13 +759,22 @@
return from the interpreter do we need to finalize the struct gcpro
itself, and that's done at case Breturn.
*/
+
+ /* See comment above explaining the `[1]' */
GCPRO1 (stack_ptr[1]);
while (1)
{
REGISTER Opcode opcode = (Opcode) READ_UINT_1;
+#ifdef ERROR_CHECK_BYTE_CODE
+ remember_operation (opcode);
+#endif
+
GCPRO_STACK; /* Get nvars right before maybe signaling. */
+ /* #### NOTE: This code should probably never get triggered, since we
+ now catch the problems earlier, farther down, before we ever set
+ a bad value for STACK_PTR. */
#ifdef ERROR_CHECK_BYTE_CODE
if (stack_ptr > stack_end)
stack_overflow ("byte code stack overflow", Qunbound);
@@ -790,7 +799,13 @@
{
/* We're not sure what these do, so better safe than sorry. */
/* GCPRO_STACK; */
- stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode);
+ stack_ptr = execute_rare_opcode (stack_ptr,
+#ifdef ERROR_CHECK_BYTE_CODE
+ stack_beg,
+ stack_end,
+#endif /* ERROR_CHECK_BYTE_CODE */
+ program_ptr, opcode);
+ CHECK_STACKPTR_OFFSET (0);
}
break;
@@ -1438,6 +1453,10 @@
Don't make this function static, since then the compiler might inline it. */
Lisp_Object *
execute_rare_opcode (Lisp_Object *stack_ptr,
+#ifdef ERROR_CHECK_BYTE_CODE
+ Lisp_Object *stack_beg,
+ Lisp_Object *stack_end,
+#endif /* ERROR_CHECK_BYTE_CODE */
const Opbyte *UNUSED (program_ptr),
Opcode opcode)
{
@@ -1445,7 +1464,7 @@
switch (opcode)
{
-
+
case Bsave_excursion:
record_unwind_protect (save_excursion_restore,
save_excursion_save ());
@@ -1714,7 +1733,7 @@
case Bmultiple_value_call:
{
n = XINT (POP);
- DISCARD_PRESERVING_MULTIPLE_VALUES (n - 1);
+ DISCARD_PRESERVING_MULTIPLE_VALUES_UNSAFE (n - 1);
/* Discard multiple values for the first (function) argument: */
TOP_LVALUE = TOP;
TOP_LVALUE = multiple_value_call (n, TOP_ADDRESS);
@@ -1723,7 +1742,7 @@
case Bmultiple_value_list_internal:
{
- DISCARD_PRESERVING_MULTIPLE_VALUES (3);
+ DISCARD_PRESERVING_MULTIPLE_VALUES_UNSAFE (3);
TOP_LVALUE = multiple_value_list_internal (4, TOP_ADDRESS);
break;
}
@@ -1741,7 +1760,7 @@
{
Ascbyte msg[100];
sprintf (msg, "Unknown opcode %d", opcode);
- abort_with_msg (msg);
+ bytecode_abort_with_message (msg);
}
break;
}
@@ -1866,8 +1885,8 @@
Lisp_Object constants,
/* out */
Opbyte * const program,
- int * const program_length,
- int * const varbind_count)
+ Elemcount * const program_length,
+ Elemcount * const varbind_count)
{
Bytecount instructions_length = XSTRING_LENGTH (instructions);
Elemcount comfy_size = (Elemcount) (2 * instructions_length);
@@ -2131,8 +2150,8 @@
optimize_compiled_function (Lisp_Object compiled_function)
{
Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
- int program_length;
- int varbind_count;
+ Elemcount program_length;
+ Elemcount varbind_count;
Opbyte *program;
{
@@ -2704,8 +2723,8 @@
(instructions, constants, stack_depth))
{
/* This function can GC */
- int varbind_count;
- int program_length;
+ Elemcount varbind_count;
+ Elemcount program_length;
Opbyte *program;
CHECK_STRING (instructions);
@@ -2720,6 +2739,9 @@
&program_length, &varbind_count);
SPECPDL_RESERVE (varbind_count);
return execute_optimized_program (program,
+#ifdef ERROR_CHECK_BYTE_CODE
+ program_length,
+#endif
XINT (stack_depth),
XVECTOR_DATA (constants));
}
@@ -2762,7 +2784,6 @@
vars_of_bytecode (void)
{
#ifdef BYTE_CODE_METER
-
DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
A vector of vectors which holds a histogram of byte code usage.
\(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
@@ -2787,3 +2808,57 @@
}
#endif /* BYTE_CODE_METER */
}
+
+#ifdef ERROR_CHECK_BYTE_CODE
+
+/* Initialize the opcodes in the table that correspond to a base opcode
+ plus an offset (except for Bconstant). */
+
+static void
+init_opcode_table_multi_op (Opcode op)
+{
+ Ascbyte *basename = opcode_name_table[op];
+ Ascbyte temp[300];
+ int i;
+
+ for (i = 1; i < 7; i++)
+ {
+ assert (!opcode_name_table[op + i]);
+ sprintf (temp, "%s+%d", basename, i);
+ opcode_name_table[op + i] = xstrdup (temp);
+ }
+}
+
+#endif /* ERROR_CHECK_BYTE_CODE */
+
+void
+reinit_vars_of_bytecode (void)
+{
+#ifdef ERROR_CHECK_BYTE_CODE
+ int i;
+
+#define OPCODE(sym, val) opcode_name_table[val] = xstrdup (#sym);
+#include "bytecode-ops.h"
+
+ for (i = 0; i < countof (opcode_name_table); i++)
+ {
+ int j;
+ Ascbyte *name = opcode_name_table[i];
+ if (name)
+ {
+ Bytecount len = strlen (name);
+ /* Prettify the name by converting underscores to hyphens, similar
+ to what happens with DEFSYMBOL. */
+ for (j = 0; j < len; j++)
+ if (name[j] == '_')
+ name[j] = '-';
+ }
+ }
+
+ init_opcode_table_multi_op (Bvarref);
+ init_opcode_table_multi_op (Bvarset);
+ init_opcode_table_multi_op (Bvarbind);
+ init_opcode_table_multi_op (Bcall);
+ init_opcode_table_multi_op (Bunbind);
+#endif /* ERROR_CHECK_BYTE_CODE */
+}
diff -r 1628e3b9601a -r 17362f371cc2 src/bytecode.h
--- a/src/bytecode.h Tue Feb 02 15:19:15 2010 -0600
+++ b/src/bytecode.h Wed Feb 03 08:01:55 2010 -0600
@@ -67,8 +67,19 @@
#define COMPILED_INTERACTIVE 5
#define COMPILED_DOMAIN 6
-/* It doesn't make sense to have this and also have load-history */
-/* #define COMPILED_FUNCTION_ANNOTATION_HACK */
+/* Someone claims: [[ It doesn't make sense to have this and also have
+ load-history ]] But in fact they are quite different things. Perhaps
+ we should turn this on only when DEBUG_XEMACS but there's no speed
+ harm at all, so no reason not to do it always. */
+#define COMPILED_FUNCTION_ANNOTATION_HACK
+
+#ifdef DEBUG_XEMACS
+/* Define BYTE_CODE_METER to enable generation of a byte-op usage
+ histogram. This isn't defined in FSF Emacs and isn't defined in XEmacs
+ v19. But this is precisely the thing to turn on when DEBUG_XEMACS. It
+ may lead to a slight speed penalty but nothing major. */
+#define BYTE_CODE_METER
+#endif
struct Lisp_Compiled_Function
{
@@ -131,6 +142,9 @@
typedef unsigned char Opbyte;
Lisp_Object execute_optimized_program (const Opbyte *program,
+#ifdef ERROR_CHECK_BYTE_CODE
+ Elemcount program_length,
+#endif
int stack_depth,
Lisp_Object *constants_data);
diff -r 1628e3b9601a -r 17362f371cc2 src/emacs.c
--- a/src/emacs.c Tue Feb 02 15:19:15 2010 -0600
+++ b/src/emacs.c Wed Feb 03 08:01:55 2010 -0600
@@ -2295,6 +2295,7 @@
/* Now do additional vars_of_*() initialization that happens both
at dump time and after pdump load. */
reinit_vars_of_buffer ();
+ reinit_vars_of_bytecode ();
reinit_vars_of_console ();
#ifdef DEBUG_XEMACS
reinit_vars_of_debug ();
diff -r 1628e3b9601a -r 17362f371cc2 src/eval.c
--- a/src/eval.c Tue Feb 02 15:19:15 2010 -0600
+++ b/src/eval.c Wed Feb 03 08:01:55 2010 -0600
@@ -3620,6 +3620,10 @@
{
Lisp_Object value =
execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions),
+#ifdef ERROR_CHECK_BYTE_CODE
+ XOPAQUE_SIZE (f->instructions) /
+ sizeof (Opbyte),
+#endif
f->stack_depth,
XVECTOR_DATA (f->constants));
diff -r 1628e3b9601a -r 17362f371cc2 src/gc.c
--- a/src/gc.c Tue Feb 02 15:19:15 2010 -0600
+++ b/src/gc.c Wed Feb 03 08:01:55 2010 -0600
@@ -1624,8 +1624,9 @@
{ /* staticpro() */
Lisp_Object **p = Dynarr_begin (staticpros);
+ Elemcount len = Dynarr_length (staticpros);
Elemcount count;
- for (count = Dynarr_length (staticpros); count; count--, p++)
+ for (count = 0; count < len; count++, p++)
/* Need to check if the pointer in the staticpro array is not
NULL. A gc can occur after variable is added to the staticpro
array and _before_ it is correctly initialized. In this case
@@ -1636,8 +1637,9 @@
{ /* staticpro_nodump() */
Lisp_Object **p = Dynarr_begin (staticpros_nodump);
+ Elemcount len = Dynarr_length (staticpros_nodump);
Elemcount count;
- for (count = Dynarr_length (staticpros_nodump); count; count--, p++)
+ for (count = 0; count < len; count++, p++)
/* Need to check if the pointer in the staticpro array is not
NULL. A gc can occur after variable is added to the staticpro
array and _before_ it is correctly initialized. In this case
@@ -1649,9 +1651,10 @@
#ifdef NEW_GC
{ /* mcpro () */
Lisp_Object *p = Dynarr_begin (mcpros);
+ Elemcount len = Dynarr_length (mcpros);
Elemcount count;
- for (count = Dynarr_length (mcpros); count; count--)
- mark_object (*p++);
+ for (count = 0; count < len; count++, p++)
+ mark_object (*p);
}
#endif /* NEW_GC */
diff -r 1628e3b9601a -r 17362f371cc2 src/lisp.h
--- a/src/lisp.h Tue Feb 02 15:19:15 2010 -0600
+++ b/src/lisp.h Wed Feb 03 08:01:55 2010 -0600
@@ -1254,7 +1254,7 @@
/* (thanks, Jamie, I feel better now -- ben) */
MODULE_API void assert_failed (const Ascbyte *, int, const Ascbyte *);
#define ABORT() assert_failed (__FILE__, __LINE__, "ABORT()")
-#define abort_with_msg(msg) assert_failed (__FILE__, __LINE__, msg)
+#define abort_with_message(msg) assert_failed (__FILE__, __LINE__, msg)
/* This used to be ((void) (0)) but that triggers lots of unused variable
warnings. It's pointless to force all that code to be rewritten, with
@@ -6009,7 +6009,7 @@
extern Lisp_Object Vcommand_line_args, Vconfigure_info_directory;
extern Lisp_Object Vconfigure_site_directory, Vconfigure_site_module_directory;
extern Lisp_Object Vconsole_list, Vcontrolling_terminal;
-extern Lisp_Object Vcurrent_compiled_function_annotation, Vcurrent_load_list;
+extern Lisp_Object Vcurrent_load_list;
extern Lisp_Object Vcurrent_mouse_event, Vcurrent_prefix_arg, Vdata_directory;
extern Lisp_Object Vdirectory_sep_char, Vdisabled_command_hook;
extern Lisp_Object Vdoc_directory, Vinternal_doc_file_name;
diff -r 1628e3b9601a -r 17362f371cc2 src/lread.c
--- a/src/lread.c Tue Feb 02 15:19:15 2010 -0600
+++ b/src/lread.c Wed Feb 03 08:01:55 2010 -0600
@@ -1,7 +1,7 @@
/* Lisp parsing and input streams.
Copyright (C) 1985-1989, 1992-1995 Free Software Foundation, Inc.
Copyright (C) 1995 Tinker Systems.
- Copyright (C) 1996, 2001, 2002, 2003 Ben Wing.
+ Copyright (C) 1996, 2001, 2002, 2003, 2010 Ben Wing.
This file is part of XEmacs.
@@ -148,7 +148,36 @@
/* A resizing-buffer stream used to temporarily hold data while reading */
static Lisp_Object Vread_buffer_stream;
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY
+/* The stuff throughout this file that sets the following variable is
+ concerned with old-style .elc files that set up compiled functions using
+
+ (fset 'fun #[... ...])
+
+ Where #[... ...] is a literal compiled-function object. We want the
+ name of the function to get stored as the annotation, so in a clever but
+ nastily kludgy fashion, we hack the code that reads lists so that if it
+ sees a symbol `fset' as the first argument, it stores the second argument
+ in Vcurrent_compiled_function_annotation, and then when the third
+ argument gets read and a compiled-function object created by a call to
+ Fmake_byte_code(), the stored annotation will get snarfed up. Elsewhere,
+ we reset Vcurrent_compiled_function_annotation to nil so it's not still
+ defined in case we have a #[... ...] in other circumstances -- in that
+ case we use the filename (Vload_file_name_internal).
+
+ Now it's arguable that I should simply have hacked Ffset()
+ appropriately. This is all moot, however, be nowadays calls that set up
+ compiled functions look like
+
+ (defalias 'fun #[... ...])
+
+ Where Fdefalias is like Ffset but sets up load-history for the function.
+ Hence it's exactly the right place to hack, and it's not even messy.
+
+ When we're sure the annotation mechanism works the new way, delete all
+ this old nasty code.
+
+ --ben 2-2-10 */
Lisp_Object Vcurrent_compiled_function_annotation;
#endif
@@ -1451,7 +1480,7 @@
internal_bind_lisp_object (&Vcurrent_load_list, Qnil);
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY
Vcurrent_compiled_function_annotation = Qnil;
#endif
GCPRO2 (val, sourcename);
@@ -1619,7 +1648,7 @@
Vread_objects = Qnil;
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY
Vcurrent_compiled_function_annotation = Qnil;
#endif
if (EQ (stream, Qread_char))
@@ -1648,7 +1677,7 @@
Lisp_Object lispstream = Qnil;
struct gcpro gcpro1;
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY
Vcurrent_compiled_function_annotation = Qnil;
#endif
GCPRO1 (lispstream);
@@ -3009,7 +3038,7 @@
}
}
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY
if (s->length == 1 && s->allow_dotted_lists && EQ (XCAR (s->head), Qfset))
{
if (CONSP (elt) && EQ (XCAR (elt), Qquote) && CONSP (XCDR (elt)))
@@ -3054,7 +3083,7 @@
{
struct read_list_state s;
struct gcpro gcpro1, gcpro2;
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY
Lisp_Object old_compiled_function_annotation =
Vcurrent_compiled_function_annotation;
#endif
@@ -3067,7 +3096,7 @@
GCPRO2 (s.head, s.tail);
sequence_reader (readcharfun, terminator, &s, read_list_conser);
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY
Vcurrent_compiled_function_annotation = old_compiled_function_annotation;
#endif
@@ -3477,7 +3506,7 @@
Vload_file_name_internal = Qnil;
staticpro (&Vload_file_name_internal);
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK_OLD_WAY
Vcurrent_compiled_function_annotation = Qnil;
staticpro (&Vcurrent_compiled_function_annotation);
#endif
diff -r 1628e3b9601a -r 17362f371cc2 src/symbols.c
--- a/src/symbols.c Tue Feb 02 15:19:15 2010 -0600
+++ b/src/symbols.c Wed Feb 03 08:01:55 2010 -0600
@@ -54,6 +54,8 @@
#include <config.h>
#include "lisp.h"
+#include "bytecode.h" /* for COMPILED_FUNCTION_ANNOTATION_HACK,
+ defined in bytecode.h and used here. */
#include "buffer.h" /* for Vbuffer_defaults */
#include "console-impl.h"
#include "elhash.h"
@@ -716,12 +718,19 @@
DEFUN ("define-function", Fdefine_function, 2, 2, 0, /*
Set SYMBOL's function definition to NEWDEF, and return NEWDEF.
Associates the function with the current load file, if any.
+If NEWDEF is a compiled-function object, stores the function name in
+the `annotated' slot of the compiled-function (retrievable using
+`compiled-function-annotation').
*/
(symbol, newdef))
{
/* This function can GC */
Ffset (symbol, newdef);
LOADHIST_ATTACH (Fcons (Qdefun, symbol));
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+ if (COMPILED_FUNCTIONP (newdef))
+ XCOMPILED_FUNCTION (newdef)->annotated = symbol;
+#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
return newdef;
}
@@ -3553,9 +3562,9 @@
temp[i] = '-';
*location = Fintern (make_string ((const Ibyte *) temp, len), Qnil);
if (dump_p)
- staticpro (location);
+ staticpro_1 (location, name);
else
- staticpro_nodump (location);
+ staticpro_nodump_1 (location, name);
}
void
@@ -3589,7 +3598,7 @@
*location = Fintern (make_string_nocopy ((const Ibyte *) name,
strlen (name)),
Qnil);
- staticpro_nodump (location);
+ staticpro_nodump_1 (location, name);
}
void
@@ -3598,7 +3607,7 @@
*location = Fintern (make_string_nocopy ((const Ibyte *) name,
strlen (name)),
Qnil);
- staticpro (location);
+ staticpro_1 (location, name);
}
void
diff -r 1628e3b9601a -r 17362f371cc2 src/symeval.h
--- a/src/symeval.h Tue Feb 02 15:19:15 2010 -0600
+++ b/src/symeval.h Wed Feb 03 08:01:55 2010 -0600
@@ -460,7 +460,7 @@
DEFVAR_SYMVAL_FWD (lname, c_location, forward_type, magicfun); \
{ \
Lisp_Object *DSF_location = c_location; /* Type check */ \
- staticpro (DSF_location); \
+ staticpro_1 (DSF_location, lname); \
if (EQ (*DSF_location, Qnull_pointer)) *DSF_location = Qnil; \
} \
} while (0)
diff -r 1628e3b9601a -r 17362f371cc2 src/symsinit.h
--- a/src/symsinit.h Tue Feb 02 15:19:15 2010 -0600
+++ b/src/symsinit.h Wed Feb 03 08:01:55 2010 -0600
@@ -333,6 +333,7 @@
void vars_of_buffer (void);
void reinit_vars_of_buffer (void);
void vars_of_bytecode (void);
+void reinit_vars_of_bytecode (void);
void vars_of_callint (void);
EXTERN_C void vars_of_canna_api (void);
void vars_of_chartab (void);
More information about the XEmacs-Patches
mailing list