Mercurial > hg > xemacs-beta
changeset 1957:59e1bbea04fe
[xemacs-hg @ 2004-03-19 02:59:08 by james]
Break infinite loop that made debug-allocation unusable.
author | james |
---|---|
date | Fri, 19 Mar 2004 02:59:10 +0000 |
parents | 2aa9359b1615 |
children | 308063db4f18 |
files | src/ChangeLog src/alloc.c src/lisp.h src/print.c |
diffstat | 4 files changed, 119 insertions(+), 18 deletions(-) [+] |
line wrap: on
line diff
--- a/src/ChangeLog Thu Mar 18 22:50:44 2004 +0000 +++ b/src/ChangeLog Fri Mar 19 02:59:10 2004 +0000 @@ -1,3 +1,26 @@ +2004-03-16 Jerry James <james@xemacs.org> + + * alloc.c: Make gc_currently_forbidden readable in other files. + * lisp.h: Add a declaration for gc_currently_forbidden. + * print.c: Add a debug_bindings struct to bind without consing. + * print.c (debug_prin1_bindings): New variable. + * print.c (output_string): Avoid calling begin_gc_forbidden, which + conses, if it is already forbidden. + * print.c (print_internal): Do not bump print_depth, which + involves consing, when inhibit_non_essential_printing_operations + is set, in which case we set print_depth to zero anyway. + * print.c (alternate_do_size): New variable. + * print.c (alternate_do_string): Dynamically allocated to avoid a + buffer overflow bug. + * print.c (write_string_to_alternate_debugging_output): Make sure + we do not overflow alternate_do_string. + * print.c (debug_prin1_exit): New function. Unbind variables + bound by debug_prin1. + * print.c (debug_prin1): Avoid using internal_bind_int, which + conses; use debug_binding instead. Always inhibit quit. + * print.c (vars_of_print): Initialize debug_prin1_bindings, + alternate_do_size, and alternate_do_string. + 2004-03-15 Jerry James <james@xemacs.org> * eval.c (grow_specpdl): Add some specpdl space, even when not
--- a/src/alloc.c Thu Mar 18 22:50:44 2004 +0000 +++ b/src/alloc.c Fri Mar 19 02:59:10 2004 +0000 @@ -187,7 +187,7 @@ /* Nonzero when calling certain hooks or doing other things where a GC would be bad */ -static int gc_currently_forbidden; +int gc_currently_forbidden; /* Hooks. */ Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
--- a/src/lisp.h Thu Mar 18 22:50:44 2004 +0000 +++ b/src/lisp.h Fri Mar 19 02:59:10 2004 +0000 @@ -3367,6 +3367,7 @@ void register_post_gc_action (void (*fun) (void *), void *arg); int begin_gc_forbidden (void); void end_gc_forbidden (int count); +extern int gc_currently_forbidden; END_C_DECLS
--- a/src/print.c Thu Mar 18 22:50:44 2004 +0000 +++ b/src/print.c Fri Mar 19 02:59:10 2004 +0000 @@ -119,6 +119,21 @@ static void write_string_to_alternate_debugging_output (const Ibyte *str, Bytecount len); +/* To avoid consing in debug_prin1, we package up variables we need to bind + into an opaque object. */ +struct debug_bindings +{ + int inhibit_non_essential_printing_operations; + int print_depth; + int print_readably; + int print_unbuffered; + int gc_currently_forbidden; + Lisp_Object Vprint_length; + Lisp_Object Vprint_level; + Lisp_Object Vinhibit_quit; +}; + +static Lisp_Object debug_prin1_bindings; int stdout_needs_newline; @@ -413,6 +428,13 @@ memcpy (copied, newnonreloc + offset, len); Lstream_write (XLSTREAM (function), copied, len); } + else if (gc_currently_forbidden) + { + /* Avoid calling begin_gc_forbidden, which conses. We can reach + this point from the cons debug code, which will get us into + an infinite loop if we cons again. */ + Lstream_write (XLSTREAM (function), newnonreloc + offset, len); + } else { int speccount = begin_gc_forbidden (); @@ -1535,10 +1557,16 @@ } being_printed[print_depth] = obj; - specdepth = internal_bind_int (&print_depth, print_depth + 1); - if (print_depth > PRINT_CIRCLE) - signal_error (Qstack_overflow, "Apparently circular structure being printed", Qunbound); + /* Avoid calling internal_bind_int, which conses, when called from + debug_prin1. In that case, we have bound print_depth to 0 anyway. */ + if (!inhibit_non_essential_printing_operations) + { + specdepth = internal_bind_int (&print_depth, print_depth + 1); + + if (print_depth > PRINT_CIRCLE) + signal_error (Qstack_overflow, "Apparently circular structure being printed", Qunbound); + } switch (XTYPE (obj)) { @@ -1712,7 +1740,8 @@ } } - unbind_to (specdepth); + if (!inhibit_non_essential_printing_operations) + unbind_to (specdepth); UNGCPRO; } @@ -1857,7 +1886,8 @@ not working. */ static int alternate_do_pointer; -static char alternate_do_string[5000]; +static int alternate_do_size; +static char *alternate_do_string; DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /* Append CHARACTER to the array `alternate_do_string'. @@ -1893,6 +1923,17 @@ extlen = len; extptr = (Extbyte *) str; } + + /* If not yet initialized, just skip it. */ + if (alternate_do_string == NULL) + return; + + if (alternate_do_pointer + extlen >= alternate_do_size) + { + alternate_do_size = + max(alternate_do_size * 2, alternate_do_pointer + extlen + 1); + XREALLOC_ARRAY (alternate_do_string, char, alternate_do_size); + } memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen); alternate_do_pointer += extlen; alternate_do_string[alternate_do_pointer] = 0; @@ -2012,11 +2053,29 @@ static int debug_print_level = 15; static int debug_print_readably = -1; +/* Restore values temporarily bound by debug_prin1. We use this approach to + avoid consing in debug_prin1. That is verboten, since debug_prin1 can be + called by cons debugging code. */ +static Lisp_Object +debug_prin1_exit (Lisp_Object ignored UNUSED_ARG) +{ + struct debug_bindings *bindings = + (struct debug_bindings *) XOPAQUE (debug_prin1_bindings)->data; + inhibit_non_essential_printing_operations = + bindings->inhibit_non_essential_printing_operations; + print_depth = bindings->print_depth; + print_readably = bindings->print_readably; + print_unbuffered = bindings->print_unbuffered; + gc_currently_forbidden = bindings->gc_currently_forbidden; + Vprint_length = bindings->Vprint_length; + Vprint_level = bindings->Vprint_level; + Vinhibit_quit = bindings->Vinhibit_quit; + return Qnil; +} + /* Print an object, `prin1'-style, to various possible debugging outputs. Make sure it's completely unbuffered so that, in the event of a crash somewhere, we see as much as possible that happened before it. - - */ static void debug_prin1 (Lisp_Object debug_print_obj, int flags) @@ -2025,19 +2084,30 @@ /* by doing this, we trick various things that are non-essential but might cause crashes into not getting executed. */ - int specdepth = - internal_bind_int (&inhibit_non_essential_printing_operations, 1); + int specdepth; + struct debug_bindings *bindings = + (struct debug_bindings *) XOPAQUE (debug_prin1_bindings)->data; - internal_bind_int (&print_depth, 0); - internal_bind_int (&print_readably, - debug_print_readably != -1 ? debug_print_readably : 0); - internal_bind_int (&print_unbuffered, print_unbuffered + 1); + bindings->inhibit_non_essential_printing_operations = + inhibit_non_essential_printing_operations; + bindings->print_depth = print_depth; + bindings->print_readably = print_readably; + bindings->print_unbuffered = print_unbuffered; + bindings->gc_currently_forbidden = gc_currently_forbidden; + bindings->Vprint_length = Vprint_length; + bindings->Vprint_level = Vprint_level; + bindings->Vinhibit_quit = Vinhibit_quit; + specdepth = record_unwind_protect (debug_prin1_exit, Qnil); + + inhibit_non_essential_printing_operations = 1; + print_depth = 0; + print_readably = debug_print_readably != -1 ? debug_print_readably : 0; + print_unbuffered++; if (debug_print_length > 0) - internal_bind_lisp_object (&Vprint_length, make_int (debug_print_length)); + Vprint_length = make_int (debug_print_length); if (debug_print_level > 0) - internal_bind_lisp_object (&Vprint_level, make_int (debug_print_level)); - /* #### Do we need this? It was in the old code. */ - internal_bind_lisp_object (&Vinhibit_quit, Vinhibit_quit); + Vprint_level = make_int (debug_print_level); + Vinhibit_quit = Qt; if ((flags & EXT_PRINT_STDOUT) || (flags & EXT_PRINT_STDERR)) print_internal (debug_print_obj, Qexternal_debugging_output, 1); @@ -2406,4 +2476,11 @@ generally be bound with `let' rather than set. (See `display-message'.) */ ); Vprint_message_label = Qprint; + + debug_prin1_bindings = + make_opaque (OPAQUE_UNINIT, sizeof (struct debug_bindings)); + staticpro (&debug_prin1_bindings); + + alternate_do_size = 5000; + alternate_do_string = xnew_array(char, 5000); }