xemacs-beta: src/alloc.c comparison

comparison 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

comparison

equal deleted inserted replaced

-:bd866891f083
+:cc15677e0335
 #include "glyphs.h"
 #include "redisplay.h"
 #include "specifier.h"
 #include "sysfile.h"
 #include "window.h"
-#include <stddef.h>
 #ifdef DOUG_LEA_MALLOC
 #include <malloc.h>
 #endif
 return imp == type || imp == type + 1;
 #endif
 }
-/************************************************************************/
+/**********************************************************************/
-/*			  Debugger support				*/
+/*			  Debugger support			      */
-/************************************************************************/
+/**********************************************************************/
-/* Give gdb/dbx enough information to decode Lisp Objects.  We make
+/* Give gdb/dbx enough information to decode Lisp Objects.
-sure certain symbols are always defined, so gdb doesn't complain
+We make sure certain symbols are defined, so gdb doesn't complain
-about expressions in src/gdbinit.  See src/gdbinit or src/dbxrc to
+about expressions in src/gdbinit.  Values are randomly chosen.
-see how this is used.  */
+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;
+dbg_valmask = (EMACS_INT) (((1UL << VALBITS) - 1) << GCBITS),
-EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
+dbg_typemask = (EMACS_INT) ((1UL << GCTYPEBITS) - 1),
-unsigned char dbg_USE_MINIMAL_TAGBITS = 1;
+dbg_USE_MINIMAL_TAGBITS = 1,
-unsigned char Lisp_Type_Int = 100;
+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
-EMACS_UINT dbg_valmask = (1UL << VALBITS) - 1;
+dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0,
-EMACS_UINT dbg_typemask = ((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS);
+#endif
-unsigned char dbg_USE_MINIMAL_TAGBITS = 0;
+dbg_Lisp_Type_Char = Lisp_Type_Char,
-#endif
+dbg_Lisp_Type_Record = Lisp_Type_Record,
+#ifdef LRECORD_CONS
-#ifdef USE_UNION_TYPE
+dbg_Lisp_Type_Cons = 101,
-unsigned char dbg_USE_UNION_TYPE = 1;
 #else
-unsigned char dbg_USE_UNION_TYPE = 0;
+dbg_Lisp_Type_Cons = Lisp_Type_Cons,
-#endif
+lrecord_cons = 201,
+#endif
-#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
+#ifdef LRECORD_STRING
-unsigned char dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1;
+dbg_Lisp_Type_String = 102,
 #else
-unsigned char dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0;
+dbg_Lisp_Type_String = Lisp_Type_String,
-#endif
+lrecord_string = 202,
+#endif
-#ifdef LRECORD_CONS
+#ifdef LRECORD_VECTOR
-unsigned char Lisp_Type_Cons = 101;
+dbg_Lisp_Type_Vector = 103,
 #else
-unsigned char lrecord_cons;
+dbg_Lisp_Type_Vector = Lisp_Type_Vector,
-#endif
+lrecord_vector = 203,
+#endif
-#ifdef LRECORD_STRING
+#ifdef LRECORD_SYMBOL
-unsigned char Lisp_Type_String = 102;
+dbg_Lisp_Type_Symbol = 104,
 #else
-unsigned char lrecord_string;
+dbg_Lisp_Type_Symbol = Lisp_Type_Symbol,
-#endif
+lrecord_symbol = 204,
+#endif
-#ifdef LRECORD_VECTOR
-unsigned char Lisp_Type_Vector = 103;
-#else
-unsigned char lrecord_vector;
-#endif
-#ifdef LRECORD_SYMBOL
-unsigned char Lisp_Type_Symbol = 104;
-#else
-unsigned char lrecord_symbol;
-#endif
 #ifndef MULE
-unsigned char lrecord_char_table_entry;
+lrecord_char_table_entry = 205,
-unsigned char lrecord_charset;
+lrecord_charset          = 206,
-#ifndef FILE_CODING
+lrecord_coding_system    = 207,
-unsigned char lrecord_coding_system;
+#endif
-#endif
-#endif
 #ifndef HAVE_TOOLBARS
-unsigned char lrecord_toolbar_button;
+lrecord_toolbar_button   = 208,
 #endif
+#ifndef HAVE_TOOLTALK
-#ifndef TOOLTALK
+lrecord_tooltalk_message = 210,
-unsigned char lrecord_tooltalk_message;
+lrecord_tooltalk_pattern = 211,
-unsigned char lrecord_tooltalk_pattern;
+#endif
-#endif
 #ifndef HAVE_DATABASE
-unsigned char lrecord_database;
+lrecord_database = 212,
 #endif
+dbg_valbits = VALBITS,
-unsigned char dbg_valbits = VALBITS;
+dbg_gctypebits = GCTYPEBITS
-unsigned char 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 :-( */
-/* Macros turned into functions for ease of debugging.
+} dbg_dummy;
-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);
-}
 /**********************************************************************/
 /*                        Fixed-size type macros                      */
 /**********************************************************************/
 Even if Emacs is run on some weirdo system that allows and allocates
 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
+#if INTBITS == 32
-# define INVALID_POINTER_VALUE 0xFFFFFFFFUL
+# define INVALID_POINTER_VALUE 0xFFFFFFFF
-#elif SIZEOF_LONG == 8
+#elif INTBITS == 48
-# define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFFUL
+# 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)
+(* (void **) ptr == (void *) INVALID_POINTER_VALUE)
-#define MARK_STRUCT_AS_FREE(ptr) memset (ptr, 0xff, sizeof (void *))
+#define MARK_STRUCT_AS_FREE(ptr) \
-#define MARK_STRUCT_AS_NOT_FREE(ptr) memset (ptr, 0x00, sizeof (void *))
+(* (void **) ptr = (void *) INVALID_POINTER_VALUE)
+#define MARK_STRUCT_AS_NOT_FREE(ptr) \
+(* (void **) ptr = 0)
 #ifdef ERROR_CHECK_GC
 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr)		\
 do { if (type##_free_list_tail)						\
 #endif
 p->name = XSTRING (str);
 p->plist = Qnil;
 p->value = Qunbound;
 p->function = Qunbound;
-p->obarray_flags = 0;
+p->obarray = Qnil;
-symbol_next (p)  = 0;
+symbol_next (p) = 0;
 XSETSYMBOL (val, p);
 return val;
 }
 ALIGNOF (struct Lisp_String *))
 #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;
 unsigned char chars[1];
 };
 allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
 			      EMACS_INT fullsize)
 {
 struct string_chars *s_chars;
-if (fullsize <=
+/* Allocate the string's actual data */
-(countof (current_string_chars_block->string_chars)
+if (BIG_STRING_FULLSIZE_P (fullsize))
-- current_string_chars_block->pos))
+{
+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 *)
 	(current_string_chars_block->string_chars
 	 + current_string_chars_block->pos);
 Lisp_Object
 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);
 #ifdef LRECORD_STRING
 set_lheader_implementation (&(s->lheader), lrecord_string);
 #endif
-set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
+s_chars = allocate_string_chars_struct (s, fullsize);
-		   ? xnew_array (Bufbyte, length + 1)
-		   : allocate_string_chars_struct (s, fullsize)->chars);
+set_string_data (s, &(s_chars->chars[0]));
 set_string_length (s, length);
 s->plist = Qnil;
 set_string_byte (s, length, 0);
 */
 void
 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
 {
-Bytecount oldfullsize, newfullsize;
 #ifdef VERIFY_STRING_CHARS_INTEGRITY
 verify_string_chars_integrity ();
 #endif
 #ifdef ERROR_CHECK_BUFPOS
 if (delta < 0)
 	assert ((-delta) <= string_length (s));
 }
 #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;
+else
-if (pos >= 0 && delta < 0)
+{
-/* If DELTA < 0, the functions below will delete the characters
+Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
-before POS.  We want to delete characters *after* POS, however,
+Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
-so convert this to the appropriate form. */
-pos += -delta;
+if (oldfullsize == newfullsize)
-oldfullsize = STRING_FULLSIZE (string_length (s));
-newfullsize = STRING_FULLSIZE (string_length (s) + delta);
-if (BIG_STRING_FULLSIZE_P (oldfullsize))
-{
-if (BIG_STRING_FULLSIZE_P (newfullsize))
 	{
-	  /* Both strings are big.  We can just realloc().
+	  /* next simplest case; size change but the necessary
-	     But careful!  If the string is shrinking, we have to
+	     allocation size won't change (up or down; code somewhere
-	     memmove() _before_ realloc(), and if growing, we have to
+	     depends on there not being any unused allocation space,
-	     memmove() _after_ realloc() - otherwise the access is
+	     modulo any alignment constraints). */
-	     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);
 	  if (pos >= 0)
 	    {
-	      memcpy (new_data, old_data, pos);
+	      Bufbyte *addroff = pos + string_data (s);
-	      memcpy (new_data + pos + delta, old_data + pos,
-		      string_length (s) + 1 - pos);
+	      memmove (addroff + delta, addroff,
+		       /* +1 due to zero-termination. */
+		       string_length (s) + 1 - pos);
 	    }
-	  set_string_data (s, new_data);
-	  xfree (old_data);
 	}
-}
+else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
-else /* old string is small */
+	       BIG_STRING_FULLSIZE_P (newfullsize))
-{
-if (oldfullsize == newfullsize)
 	{
-	  /* special case; size change but the necessary
+	  /* next simplest case; the string is big enough to be malloc()ed
-	     allocation size won't change (up or down; code
+	     itself, so we just realloc.
-	     somewhere depends on there not being any unused
-	     allocation space, modulo any alignment
+	     It's important not to let the string get below the threshold
-	     constraints). */
+	     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);
 	      memmove (addroff + delta, addroff,
 		       string_length (s) + 1 - pos);
 	    }
 	}
 else
 	{
-	  Bufbyte *old_data = string_data (s);
+	  /* worst case.  We make a new string_chars struct and copy
-	  Bufbyte *new_data =
+	     the string's data into it, inserting/deleting the delta
-	    BIG_STRING_FULLSIZE_P (newfullsize)
+	     in the process.  The old string data will either get
-	    ? xnew_array (Bufbyte, string_length (s) + delta + 1)
+	     freed by us (if it was malloc()ed) or will be reclaimed
-	    : allocate_string_chars_struct (s, newfullsize)->chars;
+	     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_addr, old_addr, pos);
-	      memcpy (new_data + pos + delta, old_data + pos,
+	      memcpy (new_addr + pos + delta, old_addr + pos,
 		      string_length (s) + 1 - pos);
 	    }
-	  set_string_data (s, new_data);
+	  set_string_data (s, new_addr);
+	  if (BIG_STRING_FULLSIZE_P (oldfullsize))
-	  {
+	    xfree (old_addr);
-	    /* We need to mark this chunk of the string_chars_block
+	  else
-	       as unused so that compact_string_chars() doesn't
+	    {
-	       freak. */
+	      /* We need to mark this chunk of the string_chars_block
-	    struct string_chars *old_s_chars = (struct string_chars *)
+		 as unused so that compact_string_chars() doesn't
-	      ((char *) old_data - offsetof (struct string_chars, chars));
+		 freak. */
-	    /* Sanity check to make sure we aren't hosed by strange
+	      struct string_chars *old_s_chars =
-	       alignment/padding. */
+		(struct string_chars *) ((char *) old_addr -
-	    assert (old_s_chars->string == s);
+					 sizeof (struct Lisp_String *));
-	    MARK_STRUCT_AS_FREE (old_s_chars);
+	      /* Sanity check to make sure we aren't hosed by strange
-	    ((struct unused_string_chars *) old_s_chars)->fullsize =
+	         alignment/padding. */
-	      oldfullsize;
+	      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);
-set_string_length (s, string_length (s) + delta);
+/* If pos < 0, the string won't be zero-terminated.
-/* If pos < 0, the string won't be zero-terminated.
+	 Terminate now just to make sure. */
-Terminate now just to make sure. */
+string_data (s)[string_length (s)] = '\0';
-string_data (s)[string_length (s)] = '\0';
+if (pos >= 0)
-if (pos >= 0)
+	{
-{
+	  Lisp_Object string;
-Lisp_Object string;
+	  XSETSTRING (string, s);
-XSETSTRING (string, s);
+	  /* We also have to adjust all of the extent indices after the
-/* We also have to adjust all of the extent indices after the
+	     place we did the change.  We say "pos - 1" because
-	 place we did the change.  We say "pos - 1" because
+	     adjust_extents() is exclusive of the starting position
-	 adjust_extents() is exclusive of the starting position
+	     passed to it. */
-	 passed to it. */
+	  adjust_extents (string, pos - 1, string_length (s),
-adjust_extents (string, pos - 1, string_length (s),
+			  delta);
-		      delta);
+	}
 }
 #ifdef VERIFY_STRING_CHARS_INTEGRITY
 verify_string_chars_integrity ();
 #endif
 else if (FLOATP (obj))
 return make_pure_float (float_data (XFLOAT (obj)));
 #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
 	     * can contain uninterned symbols.  If there are no
 	     * other non-pure references to the symbol, then the
 	     * that is referenced by a pure object.  All such
 	     * symbols are stored in the hashtable pointed to by
 	     * Vpure_uninterned_symbol_table, which is itself
 	     * staticpro'd.
 	     */
-	    if (!(mask & 1))
+	    if (!NILP (XSYMBOL (obj)->obarray))
-	      /* Symbol is not interned anywhere.  Keep a reference to the
+	      return obj;
-		 end of time.  */
+	    Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
-	      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;
 	    return obj;
 	  }
 	else
 signal_simple_error ("Can't purecopy %S", obj);
 }
 if (debug) debug_string_purity_print (p);	\
 } while (0)
 # 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
 # define MARKED_string_P(ptr) XMARKBIT ((ptr)->plist)
 if (debug) debug_string_purity_print (p);	\
 } while (0)
 # 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 */
 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
 Vdoc_directory = Qnil;
 Vconfigure_info_directory = Qnil;
 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) || \
 			   defined(LOADHIST_BUILTIN))
 Vload_history = Qnil;

Mercurial > hg > xemacs-beta

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