diff src/alloc.c @ 371:cc15677e0335 r21-2b1

Import from CVS: tag r21-2b1
author cvs
date Mon, 13 Aug 2007 11:03:08 +0200
parents 1d62742628b6
children a300bb07d72d
line wrap: on
line diff
--- a/src/alloc.c	Mon Aug 13 11:01:58 2007 +0200
+++ b/src/alloc.c	Mon Aug 13 11:03:08 2007 +0200
@@ -56,8 +56,6 @@
 #include "sysfile.h"
 #include "window.h"
 
-#include <stddef.h>
-
 #ifdef DOUG_LEA_MALLOC
 #include <malloc.h>
 #endif
@@ -636,93 +634,78 @@
 }
 
 
-/************************************************************************/
-/*			  Debugger support				*/
-/************************************************************************/
-/* Give gdb/dbx enough information to decode Lisp Objects.  We make
-   sure certain symbols are always defined, so gdb doesn't complain
-   about expressions in src/gdbinit.  See src/gdbinit or src/dbxrc to
-   see how this is used.  */
-
+/**********************************************************************/
+/*			  Debugger support			      */
+/**********************************************************************/
+/* Give gdb/dbx enough information to decode Lisp Objects.
+   We make sure certain symbols are defined, so gdb doesn't complain
+   about expressions in src/gdbinit.  Values are randomly chosen.
+   See src/gdbinit or src/dbxrc to see how this is used.  */
+
+enum dbg_constants
+{
 #ifdef USE_MINIMAL_TAGBITS
-EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
-EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
-unsigned char dbg_USE_MINIMAL_TAGBITS = 1;
-unsigned char Lisp_Type_Int = 100;
-#else
-EMACS_UINT dbg_valmask = (1UL << VALBITS) - 1;
-EMACS_UINT dbg_typemask = ((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS);
-unsigned char dbg_USE_MINIMAL_TAGBITS = 0;
-#endif
-
-#ifdef USE_UNION_TYPE
-unsigned char dbg_USE_UNION_TYPE = 1;
+  dbg_valmask = (EMACS_INT) (((1UL << VALBITS) - 1) << GCBITS),
+  dbg_typemask = (EMACS_INT) ((1UL << GCTYPEBITS) - 1),
+  dbg_USE_MINIMAL_TAGBITS = 1,
+  dbg_Lisp_Type_Int = 100,
+#else /* ! USE_MIMIMAL_TAGBITS */
+  dbg_valmask = (EMACS_INT) ((1UL << VALBITS) - 1),
+  dbg_typemask = (EMACS_INT) (((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS)),
+  dbg_USE_MINIMAL_TAGBITS = 0,
+  dbg_Lisp_Type_Int = Lisp_Type_Int,
+#endif /* ! USE_MIMIMAL_TAGBITS */
+#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
+  dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1,
 #else
-unsigned char dbg_USE_UNION_TYPE = 0;
+  dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0,
 #endif
-
-#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
-unsigned char dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1;
-#else
-unsigned char dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0;
-#endif
-
+  dbg_Lisp_Type_Char = Lisp_Type_Char,
+  dbg_Lisp_Type_Record = Lisp_Type_Record,
 #ifdef LRECORD_CONS
-unsigned char Lisp_Type_Cons = 101;
+  dbg_Lisp_Type_Cons = 101,
 #else
-unsigned char lrecord_cons;
+  dbg_Lisp_Type_Cons = Lisp_Type_Cons,
+  lrecord_cons = 201,
 #endif
-
 #ifdef LRECORD_STRING
-unsigned char Lisp_Type_String = 102;
+  dbg_Lisp_Type_String = 102,
 #else
-unsigned char lrecord_string;
+  dbg_Lisp_Type_String = Lisp_Type_String,
+  lrecord_string = 202,
 #endif
-
 #ifdef LRECORD_VECTOR
-unsigned char Lisp_Type_Vector = 103;
+  dbg_Lisp_Type_Vector = 103,
 #else
-unsigned char lrecord_vector;
-#endif
-
-#ifdef LRECORD_SYMBOL
-unsigned char Lisp_Type_Symbol = 104;
-#else
-unsigned char lrecord_symbol;
+  dbg_Lisp_Type_Vector = Lisp_Type_Vector,
+  lrecord_vector = 203,
 #endif
-
+#ifdef LRECORD_SYMBOL
+  dbg_Lisp_Type_Symbol = 104,
+#else
+  dbg_Lisp_Type_Symbol = Lisp_Type_Symbol,
+  lrecord_symbol = 204,
+#endif
 #ifndef MULE
-unsigned char lrecord_char_table_entry;
-unsigned char lrecord_charset;
-#ifndef FILE_CODING
-unsigned char lrecord_coding_system;
-#endif
-#endif
-
-#ifndef HAVE_TOOLBARS
-unsigned char lrecord_toolbar_button;
+  lrecord_char_table_entry = 205,
+  lrecord_charset          = 206,
+  lrecord_coding_system    = 207,
 #endif
-
-#ifndef TOOLTALK
-unsigned char lrecord_tooltalk_message;
-unsigned char lrecord_tooltalk_pattern;
+#ifndef HAVE_TOOLBARS
+  lrecord_toolbar_button   = 208,
 #endif
-
-#ifndef HAVE_DATABASE
-unsigned char lrecord_database;
+#ifndef HAVE_TOOLTALK
+  lrecord_tooltalk_message = 210,
+  lrecord_tooltalk_pattern = 211,
 #endif
-
-unsigned char dbg_valbits = VALBITS;
-unsigned char dbg_gctypebits = GCTYPEBITS;
-
-/* Macros turned into functions for ease of debugging.
-   Debuggers don't know about macros! */
-int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
-int
-dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
-{
-  return EQ (obj1, obj2);
-}
+#ifndef HAVE_DATABASE
+  lrecord_database = 212,
+#endif
+  dbg_valbits = VALBITS,
+  dbg_gctypebits = GCTYPEBITS
+  /* If we don't have an actual object of this enum, pgcc (and perhaps
+     other compilers) might optimize away the entire type declaration :-( */
+} dbg_dummy;
 
 
 /**********************************************************************/
@@ -1022,28 +1005,22 @@
    byte-aligned pointers, this pointer is at the very top of the address
    space and so it's almost inconceivable that it could ever be valid. */
 
-#if SIZEOF_LONG == 4
-# define INVALID_POINTER_VALUE 0xFFFFFFFFUL
-#elif SIZEOF_LONG == 8
-# define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFFUL
+#if INTBITS == 32
+# define INVALID_POINTER_VALUE 0xFFFFFFFF
+#elif INTBITS == 48
+# define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
+#elif INTBITS == 64
+# define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
 #else
 You have some weird system and need to supply a reasonable value here.
 #endif
 
-/* The construct (* (void **) (ptr)) would cause aliasing problems
-   with modern optimizing compilers like `gcc -O3 -fstrict-aliasing'.
-   But `char *' can legally alias any pointer.  Hence this union trick...
-
-   It turned out that the union trick was not good enough for xlC -O3;
-   and it is questionable whether it really complies with the C standard.
-   so we use memset instead, which should be safe from optimizations. */
-typedef union { char c; void *p; } *aliasing_voidpp;
-#define ALIASING_VOIDPP_DEREFERENCE(ptr) \
-  (((aliasing_voidpp) (ptr))->p)
 #define FREE_STRUCT_P(ptr) \
-  (ALIASING_VOIDPP_DEREFERENCE (ptr) == (void *) INVALID_POINTER_VALUE)
-#define MARK_STRUCT_AS_FREE(ptr) memset (ptr, 0xff, sizeof (void *))
-#define MARK_STRUCT_AS_NOT_FREE(ptr) memset (ptr, 0x00, sizeof (void *))
+  (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
+#define MARK_STRUCT_AS_FREE(ptr) \
+  (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
+#define MARK_STRUCT_AS_NOT_FREE(ptr) \
+  (* (void **) ptr = 0)
 
 #ifdef ERROR_CHECK_GC
 
@@ -1901,8 +1878,8 @@
   p->plist = Qnil;
   p->value = Qunbound;
   p->function = Qunbound;
-  p->obarray_flags = 0;
-  symbol_next (p)  = 0;
+  p->obarray = Qnil;
+  symbol_next (p) = 0;
   XSETSYMBOL (val, p);
   return val;
 }
@@ -2090,6 +2067,11 @@
 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
 
+#define CHARS_TO_STRING_CHAR(x) \
+  ((struct string_chars *) \
+   (((char *) (x)) - (slot_offset (struct string_chars, chars[0]))))
+
+
 struct string_chars
 {
   struct Lisp_String *string;
@@ -2118,9 +2100,14 @@
 {
   struct string_chars *s_chars;
 
-  if (fullsize <=
-      (countof (current_string_chars_block->string_chars)
-       - current_string_chars_block->pos))
+  /* Allocate the string's actual data */
+  if (BIG_STRING_FULLSIZE_P (fullsize))
+    {
+      s_chars = (struct string_chars *) xmalloc (fullsize);
+    }
+  else if (fullsize <=
+           (countof (current_string_chars_block->string_chars)
+            - current_string_chars_block->pos))
     {
       /* This string can fit in the current string chars block */
       s_chars = (struct string_chars *)
@@ -2153,10 +2140,12 @@
 make_uninit_string (Bytecount length)
 {
   struct Lisp_String *s;
+  struct string_chars *s_chars;
   EMACS_INT fullsize = STRING_FULLSIZE (length);
   Lisp_Object val;
 
-  assert (length >= 0 && fullsize > 0);
+  if ((length < 0) || (fullsize <= 0))
+    abort ();
 
   /* Allocate the string header */
   ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
@@ -2164,10 +2153,9 @@
   set_lheader_implementation (&(s->lheader), lrecord_string);
 #endif
 
-  set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
-		   ? xnew_array (Bufbyte, length + 1)
-		   : allocate_string_chars_struct (s, fullsize)->chars);
-
+  s_chars = allocate_string_chars_struct (s, fullsize);
+
+  set_string_data (s, &(s_chars->chars[0]));
   set_string_length (s, length);
   s->plist = Qnil;
 
@@ -2190,7 +2178,6 @@
 void
 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
 {
-  Bytecount oldfullsize, newfullsize;
 #ifdef VERIFY_STRING_CHARS_INTEGRITY
   verify_string_chars_integrity ();
 #endif
@@ -2209,62 +2196,47 @@
     }
 #endif /* ERROR_CHECK_BUFPOS */
 
+  if (pos >= 0 && delta < 0)
+  /* If DELTA < 0, the functions below will delete the characters
+     before POS.  We want to delete characters *after* POS, however,
+     so convert this to the appropriate form. */
+    pos += -delta;
+
   if (delta == 0)
     /* simplest case: no size change. */
     return;
-
-  if (pos >= 0 && delta < 0)
-    /* If DELTA < 0, the functions below will delete the characters
-       before POS.  We want to delete characters *after* POS, however,
-       so convert this to the appropriate form. */
-    pos += -delta;
-
-  oldfullsize = STRING_FULLSIZE (string_length (s));
-  newfullsize = STRING_FULLSIZE (string_length (s) + delta);
-
-  if (BIG_STRING_FULLSIZE_P (oldfullsize))
+  else
     {
-      if (BIG_STRING_FULLSIZE_P (newfullsize))
+      Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
+      Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
+
+      if (oldfullsize == newfullsize)
 	{
-	  /* Both strings are big.  We can just realloc().
-	     But careful!  If the string is shrinking, we have to
-	     memmove() _before_ realloc(), and if growing, we have to
-	     memmove() _after_ realloc() - otherwise the access is
-	     illegal, and we might crash. */
-	  Bytecount len = string_length (s) + 1 - pos;
-
-	  if (delta < 0 && pos >= 0)
-	    memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
-	  set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
-						    string_length (s) + delta + 1));
-	  if (delta > 0 && pos >= 0)
-	    memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
-	}
-      else /* String has been demoted from BIG_STRING. */
-	{
-	  Bufbyte *new_data =
-	    allocate_string_chars_struct (s, newfullsize)->chars;
-	  Bufbyte *old_data = string_data (s);
-
+	  /* next simplest case; size change but the necessary
+	     allocation size won't change (up or down; code somewhere
+	     depends on there not being any unused allocation space,
+	     modulo any alignment constraints). */
 	  if (pos >= 0)
 	    {
-	      memcpy (new_data, old_data, pos);
-	      memcpy (new_data + pos + delta, old_data + pos,
-		      string_length (s) + 1 - pos);
+	      Bufbyte *addroff = pos + string_data (s);
+
+	      memmove (addroff + delta, addroff,
+		       /* +1 due to zero-termination. */
+		       string_length (s) + 1 - pos);
 	    }
-	  set_string_data (s, new_data);
-	  xfree (old_data);
 	}
-    }
-  else /* old string is small */
-    {
-      if (oldfullsize == newfullsize)
+      else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
+	       BIG_STRING_FULLSIZE_P (newfullsize))
 	{
-	  /* special case; size change but the necessary
-	     allocation size won't change (up or down; code
-	     somewhere depends on there not being any unused
-	     allocation space, modulo any alignment
-	     constraints). */
+	  /* next simplest case; the string is big enough to be malloc()ed
+	     itself, so we just realloc.
+
+	     It's important not to let the string get below the threshold
+	     for making big strings and still remain malloc()ed; if that
+	     were the case, repeated calls to this function on the same
+	     string could result in memory leakage. */
+	  set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
+						    newfullsize));
 	  if (pos >= 0)
 	    {
 	      Bufbyte *addroff = pos + string_data (s);
@@ -2276,52 +2248,58 @@
 	}
       else
 	{
-	  Bufbyte *old_data = string_data (s);
-	  Bufbyte *new_data =
-	    BIG_STRING_FULLSIZE_P (newfullsize)
-	    ? xnew_array (Bufbyte, string_length (s) + delta + 1)
-	    : allocate_string_chars_struct (s, newfullsize)->chars;
-
+	  /* worst case.  We make a new string_chars struct and copy
+	     the string's data into it, inserting/deleting the delta
+	     in the process.  The old string data will either get
+	     freed by us (if it was malloc()ed) or will be reclaimed
+	     in the normal course of garbage collection. */
+	  struct string_chars *s_chars =
+	    allocate_string_chars_struct (s, newfullsize);
+	  Bufbyte *new_addr = &(s_chars->chars[0]);
+	  Bufbyte *old_addr = string_data (s);
 	  if (pos >= 0)
 	    {
-	      memcpy (new_data, old_data, pos);
-	      memcpy (new_data + pos + delta, old_data + pos,
+	      memcpy (new_addr, old_addr, pos);
+	      memcpy (new_addr + pos + delta, old_addr + pos,
 		      string_length (s) + 1 - pos);
 	    }
-	  set_string_data (s, new_data);
-
-	  {
-	    /* We need to mark this chunk of the string_chars_block
-	       as unused so that compact_string_chars() doesn't
-	       freak. */
-	    struct string_chars *old_s_chars = (struct string_chars *)
-	      ((char *) old_data - offsetof (struct string_chars, chars));
-	    /* Sanity check to make sure we aren't hosed by strange
-	       alignment/padding. */
-	    assert (old_s_chars->string == s);
-	    MARK_STRUCT_AS_FREE (old_s_chars);
-	    ((struct unused_string_chars *) old_s_chars)->fullsize =
-	      oldfullsize;
-	  }
+	  set_string_data (s, new_addr);
+	  if (BIG_STRING_FULLSIZE_P (oldfullsize))
+	    xfree (old_addr);
+	  else
+	    {
+	      /* We need to mark this chunk of the string_chars_block
+		 as unused so that compact_string_chars() doesn't
+		 freak. */
+	      struct string_chars *old_s_chars =
+		(struct string_chars *) ((char *) old_addr -
+					 sizeof (struct Lisp_String *));
+	      /* Sanity check to make sure we aren't hosed by strange
+	         alignment/padding. */
+	      assert (old_s_chars->string == s);
+	      MARK_STRUCT_AS_FREE (old_s_chars);
+	      ((struct unused_string_chars *) old_s_chars)->fullsize =
+		oldfullsize;
+	    }
 	}
-    }
-
-  set_string_length (s, string_length (s) + delta);
-  /* If pos < 0, the string won't be zero-terminated.
-     Terminate now just to make sure. */
-  string_data (s)[string_length (s)] = '\0';
-
-  if (pos >= 0)
-    {
-      Lisp_Object string;
-
-      XSETSTRING (string, s);
-      /* We also have to adjust all of the extent indices after the
-	 place we did the change.  We say "pos - 1" because
-	 adjust_extents() is exclusive of the starting position
-	 passed to it. */
-      adjust_extents (string, pos - 1, string_length (s),
-		      delta);
+
+      set_string_length (s, string_length (s) + delta);
+      /* If pos < 0, the string won't be zero-terminated.
+	 Terminate now just to make sure. */
+      string_data (s)[string_length (s)] = '\0';
+
+      if (pos >= 0)
+	{
+	  Lisp_Object string;
+
+	  XSETSTRING (string, s);
+	  /* We also have to adjust all of the extent indices after the
+	     place we did the change.  We say "pos - 1" because
+	     adjust_extents() is exclusive of the starting position
+	     passed to it. */
+	  adjust_extents (string, pos - 1, string_length (s),
+			  delta);
+	}
     }
 
 #ifdef VERIFY_STRING_CHARS_INTEGRITY
@@ -2914,11 +2892,10 @@
 #endif /* LISP_FLOAT_TYPE */
 	else if (SYMBOLP (obj))
 	  {
-	    int mask = XSYMBOL_OBARRAY_FLAGS (obj);
 	    /*
 	     * Symbols can't be made pure (and thus read-only),
 	     * because assigning to their function, value or plist
-	     * slots would produce a SEGV in the dumped XEmacs.  So
+	     * slots would produced a SEGV in the dumped XEmacs.  So
 	     * we previously would just return the symbol unchanged.
 	     *
 	     * But purified aggregate objects like lists and vectors
@@ -2933,16 +2910,9 @@
 	     * Vpure_uninterned_symbol_table, which is itself
 	     * staticpro'd.
 	     */
-	    if (!(mask & 1))
-	      /* Symbol is not interned anywhere.  Keep a reference to the
-		 end of time.  */
-	      Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
-
-	    /* Mark symbol as being referenced by a pure structure.
-	       Funintern() will recognize this mark and place the symbol to
-	       Vpure_uninterned_symbol_table at the time of uninterning.  */
-	    XSYMBOL (obj)->obarray_flags = mask | 4;
-
+	    if (!NILP (XSYMBOL (obj)->obarray))
+	      return obj;
+	    Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
 	    return obj;
 	  }
 	else
@@ -4184,7 +4154,7 @@
 # define ADDITIONAL_FREE_string(p)				\
   do { int size = string_length (p);				\
        if (BIG_STRING_SIZE_P (size))				\
-	 xfree (p->_data);					\
+	 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p)));	\
      } while (0)
 
 #else
@@ -4204,7 +4174,7 @@
 # define ADDITIONAL_FREE_string(p)				\
   do { int size = string_length (p);				\
        if (BIG_STRING_SIZE_P (size))				\
-	 xfree (p->_data);					\
+	 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p)));	\
      } while (0)
 
 #endif /* ! LRECORD_STRING */
@@ -4342,10 +4312,6 @@
   Vexec_path = Qnil;
   Vload_path = Qnil;
   /* Vdump_load_path = Qnil; */
-  /* Release hash tables for locate_file */
-  Fset (intern ("early-package-load-path"), Qnil);
-  Fset (intern ("late-package-load-path"),  Qnil);
-  Fset (intern ("last-package-load-path"),  Qnil);
   uncache_home_directory();
 
 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \