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);
 }