*** empty log message ***

[bpt/emacs.git] / src / alloc.c

diff --git a/src/alloc.c b/src/alloc.c
index 54c4b44..4affa42 100644 (file)
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -1,5 +1,5 @@
 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
 /* Storage allocation and gc for GNU Emacs Lisp interpreter.

-   Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000
+   Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001

       Free Software Foundation, Inc.
 
 This file is part of GNU Emacs.
       Free Software Foundation, Inc.
 
 This file is part of GNU Emacs.


@@ -26,12 +26,6 @@ Boston, MA 02111-1307, USA.  */
 
 #include <signal.h>
 
 
 #include <signal.h>
 

-/* Define this temporarily to hunt a bug.  If defined, the size of
-   strings is redundantly recorded in sdata structures so that it can
-   be compared to the sizes recorded in Lisp strings.  */
-
-#define GC_CHECK_STRING_BYTES 1
-

 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
    memory.  Can do this only if using gmalloc.c.  */
 
 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
    memory.  Can do this only if using gmalloc.c.  */
 


@@ -655,22 +649,23 @@ emacs_blocked_free (ptr)
   BLOCK_INPUT;
 
 #ifdef GC_MALLOC_CHECK
   BLOCK_INPUT;
 
 #ifdef GC_MALLOC_CHECK

-  {
-    struct mem_node *m;
+  if (ptr)
+    {
+      struct mem_node *m;

   
   

-    m = mem_find (ptr);
-    if (m == MEM_NIL || m->start != ptr)
-      {
-       fprintf (stderr,
-                "Freeing `%p' which wasn't allocated with malloc\n", ptr);
-       abort ();
-      }
-    else
-      {
-       /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
-       mem_delete (m);
-      }
-  }
+      m = mem_find (ptr);
+      if (m == MEM_NIL || m->start != ptr)
+       {
+         fprintf (stderr,
+                  "Freeing `%p' which wasn't allocated with malloc\n", ptr);
+         abort ();
+       }
+      else
+       {
+         /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
+         mem_delete (m);
+       }
+    }

 #endif /* GC_MALLOC_CHECK */
   
   __free_hook = old_free_hook;
 #endif /* GC_MALLOC_CHECK */
   
   __free_hook = old_free_hook;


@@ -1200,50 +1195,84 @@ init_strings ()
 
 #ifdef GC_CHECK_STRING_BYTES
 
 
 #ifdef GC_CHECK_STRING_BYTES
 

-/* Check validity of all live Lisp strings' string_bytes member.
-   Used for hunting a bug.  */
-

 static int check_string_bytes_count;
 
 static int check_string_bytes_count;
 

+void check_string_bytes P_ ((int));
+void check_sblock P_ ((struct sblock *));
+
+#define CHECK_STRING_BYTES(S)  STRING_BYTES (S)
+
+
+/* Like GC_STRING_BYTES, but with debugging check.  */
+
+int
+string_bytes (s)
+     struct Lisp_String *s;
+{
+  int nbytes = (s->size_byte < 0 ? s->size : s->size_byte) & ~MARKBIT;
+  if (!PURE_POINTER_P (s)
+      && s->data
+      && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
+    abort ();
+  return nbytes;
+}
+    
+/* Check validity Lisp strings' string_bytes member in B.  */
+

 void
 void

-check_string_bytes ()
+check_sblock (b)
+     struct sblock *b;

 {
 {

-  struct sblock *b;
-  
-  for (b = large_sblocks; b; b = b->next)
-    {
-      struct Lisp_String *s = b->first_data.string;
-      if (s && GC_STRING_BYTES (s) != SDATA_NBYTES (SDATA_OF_STRING (s)))
-       abort ();
-    }
+  struct sdata *from, *end, *from_end;

       
       

-  for (b = oldest_sblock; b; b = b->next)
+  end = b->next_free;
+      
+  for (from = &b->first_data; from < end; from = from_end)

     {
     {

-      struct sdata *from, *end, *from_end;
+      /* Compute the next FROM here because copying below may
+        overwrite data we need to compute it.  */
+      int nbytes;

       
       

-      end = b->next_free;
+      /* Check that the string size recorded in the string is the
+        same as the one recorded in the sdata structure. */
+      if (from->string)
+       CHECK_STRING_BYTES (from->string);

       
       

-      for (from = &b->first_data; from < end; from = from_end)
-       {
-         /* Compute the next FROM here because copying below may
-            overwrite data we need to compute it.  */
-         int nbytes;
+      if (from->string)
+       nbytes = GC_STRING_BYTES (from->string);
+      else
+       nbytes = SDATA_NBYTES (from);
+      
+      nbytes = SDATA_SIZE (nbytes);
+      from_end = (struct sdata *) ((char *) from + nbytes);
+    }
+}

 
 

-         /* Check that the string size recorded in the string is the
-            same as the one recorded in the sdata structure. */
-         if (from->string
-             && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
-           abort ();
-         
-         if (from->string)
-           nbytes = GC_STRING_BYTES (from->string);
-         else
-           nbytes = SDATA_NBYTES (from);
-         
-         nbytes = SDATA_SIZE (nbytes);
-         from_end = (struct sdata *) ((char *) from + nbytes);
+
+/* Check validity of Lisp strings' string_bytes member.  ALL_P
+   non-zero means check all strings, otherwise check only most
+   recently allocated strings.  Used for hunting a bug.  */
+
+void
+check_string_bytes (all_p)
+     int all_p;
+{
+  if (all_p)
+    {
+      struct sblock *b;
+
+      for (b = large_sblocks; b; b = b->next)
+       {
+         struct Lisp_String *s = b->first_data.string;
+         if (s)
+           CHECK_STRING_BYTES (s);

        }
        }

+      
+      for (b = oldest_sblock; b; b = b->next)
+       check_sblock (b);

     }
     }

+  else
+    check_sblock (current_sblock);

 }
 
 #endif /* GC_CHECK_STRING_BYTES */
 }
 
 #endif /* GC_CHECK_STRING_BYTES */


@@ -1293,12 +1322,21 @@ allocate_string ()
   consing_since_gc += sizeof *s;
 
 #ifdef GC_CHECK_STRING_BYTES
   consing_since_gc += sizeof *s;
 
 #ifdef GC_CHECK_STRING_BYTES

-  if (!noninteractive && ++check_string_bytes_count == 50)
+  if (!noninteractive
+#ifdef macintosh
+      && current_sblock
+#endif
+     )

     {
     {

-      check_string_bytes_count = 0;
-      check_string_bytes ();
+      if (++check_string_bytes_count == 200)
+       {
+         check_string_bytes_count = 0;
+         check_string_bytes (1);
+       }
+      else
+       check_string_bytes (0);

     }
     }

-#endif
+#endif /* GC_CHECK_STRING_BYTES */

 
   return s;
 }
 
   return s;
 }


@@ -1627,7 +1665,7 @@ Both LENGTH and INIT must be numbers.")
     }
   else
     {
     }
   else
     {

-      unsigned char str[4];
+      unsigned char str[MAX_MULTIBYTE_LENGTH];

       int len = CHAR_STRING (c, str);
 
       nbytes = len * XINT (length);
       int len = CHAR_STRING (c, str);
 
       nbytes = len * XINT (length);


@@ -1700,12 +1738,12 @@ make_string (contents, nbytes)
   int nchars, multibyte_nbytes;
 
   parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
   int nchars, multibyte_nbytes;
 
   parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);

-  val = make_uninit_multibyte_string (nchars, nbytes);
-  bcopy (contents, XSTRING (val)->data, nbytes);

   if (nbytes == nchars || nbytes != multibyte_nbytes)
     /* CONTENTS contains no multibyte sequences or contains an invalid
        multibyte sequence.  We must make unibyte string.  */
   if (nbytes == nchars || nbytes != multibyte_nbytes)
     /* CONTENTS contains no multibyte sequences or contains an invalid
        multibyte sequence.  We must make unibyte string.  */

-    SET_STRING_BYTES (XSTRING (val), -1);
+    val = make_unibyte_string (contents, nbytes);
+  else
+    val = make_multibyte_string (contents, nchars, nbytes);

   return val;
 }
 
   return val;
 }
 


@@ -2104,8 +2142,38 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
   size = XFASTINT (length);
 
   val = Qnil;
   size = XFASTINT (length);
 
   val = Qnil;

-  while (size-- > 0)
-    val = Fcons (init, val);
+  while (size > 0)
+    {
+      val = Fcons (init, val);
+      --size;
+
+      if (size > 0)
+       {
+         val = Fcons (init, val);
+         --size;
+      
+         if (size > 0)
+           {
+             val = Fcons (init, val);
+             --size;
+      
+             if (size > 0)
+               {
+                 val = Fcons (init, val);
+                 --size;
+      
+                 if (size > 0)
+                   {
+                     val = Fcons (init, val);
+                     --size;
+                   }
+               }
+           }
+       }
+
+      QUIT;
+    }
+  

   return val;
 }
 
   return val;
 }
 


@@ -3686,7 +3754,7 @@ DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
 Returns info on amount of space in use:\n\
  ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
   (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
 Returns info on amount of space in use:\n\
  ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
   (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\

-  (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\
+  (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)\n\

   (USED-STRINGS . FREE-STRINGS))\n\
 Garbage collection happens automatically if you cons more than\n\
 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
   (USED-STRINGS . FREE-STRINGS))\n\
 Garbage collection happens automatically if you cons more than\n\
 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")


@@ -3700,7 +3768,8 @@ Garbage collection happens automatically if you cons more than\n\
   char stack_top_variable;
   register int i;
   int message_p;
   char stack_top_variable;
   register int i;
   int message_p;

-  Lisp_Object total[7];
+  Lisp_Object total[8];
+  int count = BINDING_STACK_SIZE ();

 
   /* In case user calls debug_print during GC,
      don't let that cause a recursive GC.  */
 
   /* In case user calls debug_print during GC,
      don't let that cause a recursive GC.  */


@@ -3708,6 +3777,7 @@ Garbage collection happens automatically if you cons more than\n\
 
   /* Save what's currently displayed in the echo area.  */
   message_p = push_message ();
 
   /* Save what's currently displayed in the echo area.  */
   message_p = push_message ();

+  record_unwind_protect (push_message_unwind, Qnil);

 
   /* Save a copy of the contents of the stack, for debugging.  */
 #if MAX_SAVE_STACK > 0
 
   /* Save a copy of the contents of the stack, for debugging.  */
 #if MAX_SAVE_STACK > 0


@@ -3912,7 +3982,7 @@ Garbage collection happens automatically if you cons more than\n\
        message1_nolog ("Garbage collecting...done");
     }
 
        message1_nolog ("Garbage collecting...done");
     }
 

-  pop_message ();
+  unbind_to (count, Qnil);

 
   total[0] = Fcons (make_number (total_conses),
                    make_number (total_free_conses));
 
   total[0] = Fcons (make_number (total_conses),
                    make_number (total_free_conses));


@@ -3920,13 +3990,13 @@ Garbage collection happens automatically if you cons more than\n\
                    make_number (total_free_symbols));
   total[2] = Fcons (make_number (total_markers),
                    make_number (total_free_markers));
                    make_number (total_free_symbols));
   total[2] = Fcons (make_number (total_markers),
                    make_number (total_free_markers));

-  total[3] = Fcons (make_number (total_string_size),
-                   make_number (total_vector_size));
-  total[4] = Fcons (make_number (total_floats),
+  total[3] = make_number (total_string_size);
+  total[4] = make_number (total_vector_size);
+  total[5] = Fcons (make_number (total_floats),

                    make_number (total_free_floats));
                    make_number (total_free_floats));

-  total[5] = Fcons (make_number (total_intervals),
+  total[6] = Fcons (make_number (total_intervals),

                    make_number (total_free_intervals));
                    make_number (total_free_intervals));

-  total[6] = Fcons (make_number (total_strings),
+  total[7] = Fcons (make_number (total_strings),

                    make_number (total_free_strings));
 
 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
                    make_number (total_free_strings));
 
 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES


@@ -3945,7 +4015,7 @@ Garbage collection happens automatically if you cons more than\n\
     }
 #endif
 
     }
 #endif
 

-  return Flist (7, total);
+  return Flist (sizeof total / sizeof *total, total);

 }
 
 
 }
 
 


@@ -4108,13 +4178,9 @@ mark_object (argptr)
        MARK_INTERVAL_TREE (ptr->intervals);
        MARK_STRING (ptr);
 #ifdef GC_CHECK_STRING_BYTES
        MARK_INTERVAL_TREE (ptr->intervals);
        MARK_STRING (ptr);
 #ifdef GC_CHECK_STRING_BYTES

-        {
-         /* Check that the string size recorded in the string is the
-            same as the one recorded in the sdata structure. */
-         struct sdata *p = SDATA_OF_STRING (ptr);
-         if (GC_STRING_BYTES (ptr) != SDATA_NBYTES (p))
-           abort ();
-        }
+       /* Check that the string size recorded in the string is the
+          same as the one recorded in the sdata structure. */
+       CHECK_STRING_BYTES (ptr);

 #endif /* GC_CHECK_STRING_BYTES */
       }
       break;
 #endif /* GC_CHECK_STRING_BYTES */
       }
       break;


@@ -4200,8 +4266,7 @@ mark_object (argptr)
          mark_face_cache (ptr->face_cache);
 #ifdef HAVE_WINDOW_SYSTEM
          mark_image_cache (ptr);
          mark_face_cache (ptr->face_cache);
 #ifdef HAVE_WINDOW_SYSTEM
          mark_image_cache (ptr);

-         mark_object (&ptr->desired_tool_bar_items);
-         mark_object (&ptr->current_tool_bar_items);
+         mark_object (&ptr->tool_bar_items);

          mark_object (&ptr->desired_tool_bar_string);
          mark_object (&ptr->current_tool_bar_string);
 #endif /* HAVE_WINDOW_SYSTEM */
          mark_object (&ptr->desired_tool_bar_string);
          mark_object (&ptr->current_tool_bar_string);
 #endif /* HAVE_WINDOW_SYSTEM */


@@ -4606,6 +4671,10 @@ gc_sweep ()
   sweep_weak_hash_tables ();
 
   sweep_strings ();
   sweep_weak_hash_tables ();
 
   sweep_strings ();

+#ifdef GC_CHECK_STRING_BYTES
+  if (!noninteractive)
+    check_string_bytes (1);
+#endif

 
   /* Put all unmarked conses on free list */
   {
 
   /* Put all unmarked conses on free list */
   {


@@ -4764,29 +4833,39 @@ gc_sweep ()
     register int lim = symbol_block_index;
     register int num_free = 0, num_used = 0;
 
     register int lim = symbol_block_index;
     register int num_free = 0, num_used = 0;
 

-    symbol_free_list = 0;
+    symbol_free_list = NULL;

   
     for (sblk = symbol_block; sblk; sblk = *sprev)
       {
   
     for (sblk = symbol_block; sblk; sblk = *sprev)
       {

-       register int i;

        int this_free = 0;
        int this_free = 0;

-       for (i = 0; i < lim; i++)
-         if (!XMARKBIT (sblk->symbols[i].plist))
-           {
-             *(struct Lisp_Symbol **)&sblk->symbols[i].value = symbol_free_list;
-             symbol_free_list = &sblk->symbols[i];
+       struct Lisp_Symbol *sym = sblk->symbols;
+       struct Lisp_Symbol *end = sym + lim;
+
+       for (; sym < end; ++sym)
+         {
+           /* Check if the symbol was created during loadup.  In such a case
+              it might be pointed to by pure bytecode which we don't trace,
+              so we conservatively assume that it is live.  */
+           int pure_p = PURE_POINTER_P (sym->name);
+           
+           if (!XMARKBIT (sym->plist) && !pure_p)
+             {
+               *(struct Lisp_Symbol **) &sym->value = symbol_free_list;
+               symbol_free_list = sym;

 #if GC_MARK_STACK
 #if GC_MARK_STACK

-             symbol_free_list->function = Vdead;
+               symbol_free_list->function = Vdead;

 #endif
 #endif

-             this_free++;
-           }
-         else
-           {
-             num_used++;
-             if (!PURE_POINTER_P (sblk->symbols[i].name))
-               UNMARK_STRING (sblk->symbols[i].name);
-             XUNMARK (sblk->symbols[i].plist);
-           }
+               ++this_free;
+             }
+           else
+             {
+               ++num_used;
+               if (!pure_p)
+                 UNMARK_STRING (sym->name);
+               XUNMARK (sym->plist);
+             }
+         }
+       

        lim = SYMBOL_BLOCK_SIZE;
        /* If this block contains only free symbols and we have already
           seen more than two blocks worth of free symbols then deallocate
        lim = SYMBOL_BLOCK_SIZE;
        /* If this block contains only free symbols and we have already
           seen more than two blocks worth of free symbols then deallocate


@@ -4948,6 +5027,11 @@ gc_sweep ()
          prev = vector, vector = vector->next;
        }
   }
          prev = vector, vector = vector->next;
        }
   }

+  
+#ifdef GC_CHECK_STRING_BYTES
+  if (!noninteractive)
+    check_string_bytes (1);
+#endif

 }
 
 
 }