xemacs-beta: src/alloc.c comparison

comparison src/alloc.c @ 438:84b14dcb0985 r21-2-27

Import from CVS: tag r21-2-27

author	cvs
date	Mon, 13 Aug 2007 11:32:25 +0200
parents	3ecd8885ac67
children	8de8e3f6228a

comparison

equal deleted inserted replaced

-:e2a4e8b94b82
+:84b14dcb0985
 /************************************************************************/
 /*			  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
+about expressions in src/.gdbinit.  See src/.gdbinit or src/.dbxrc
-see how this is used.  */
+to see how this is used.  */
 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
 #ifdef USE_UNION_TYPE
 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
 that the reference would get relocated).
 This new method makes things somewhat bigger, but it is MUCH safer.  */
-DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
+DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
 /* strings are used and freed quite often */
 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
 static Lisp_Object
 mark_string (Lisp_Object obj)
 {
-struct Lisp_String *ptr = XSTRING (obj);
+Lisp_String *ptr = XSTRING (obj);
 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
 flush_cached_extent_info (XCAR (ptr->plist));
 return ptr->plist;
 }
 				      * finalization when using
 				      * SWEEP_FIXED_TYPE_BLOCK().
 				      */
 				     0, string_equal, 0,
 				     string_description,
-				     struct Lisp_String);
+				     Lisp_String);
 /* String blocks contain this many useful bytes. */
 #define STRING_CHARS_BLOCK_SIZE					\
 ((Bytecount) (8192 - MALLOC_OVERHEAD -				\
 	      ((2 * sizeof (struct string_chars_block *))	\
 /* If SIZE is the length of a string, this returns how many bytes
 *  the string occupies in string_chars_block->string_chars
 *  (including alignment padding).
 */
-#define STRING_FULLSIZE(s) \
+#define STRING_FULLSIZE(size) \
-ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\
+ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
-ALIGNOF (struct Lisp_String *))
+ALIGNOF (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;
+Lisp_String *string;
 unsigned char chars[1];
 };
 struct unused_string_chars
 {
-struct Lisp_String *string;
+Lisp_String *string;
 EMACS_INT fullsize;
 };
 static void
 init_string_chars_alloc (void)
 first_string_chars_block->pos = 0;
 current_string_chars_block = first_string_chars_block;
 }
 static struct string_chars *
-allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
+allocate_string_chars_struct (Lisp_String *string_it_goes_with,
 			      EMACS_INT fullsize)
 {
 struct string_chars *s_chars;
-/* Allocate the string's actual data */
+if (fullsize <=
-if (BIG_STRING_FULLSIZE_P (fullsize))
+(countof (current_string_chars_block->string_chars)
-{
+- 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;
+Lisp_String *s;
-struct string_chars *s_chars;
 EMACS_INT fullsize = STRING_FULLSIZE (length);
 Lisp_Object val;
-if ((length < 0) || (fullsize <= 0))
+assert (length >= 0 && fullsize > 0);
-abort ();
 /* Allocate the string header */
-ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
+ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
 set_lheader_implementation (&(s->lheader), &lrecord_string);
-s_chars = allocate_string_chars_struct (s, fullsize);
+set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
+		   ? xnew_array (Bufbyte, length + 1)
-set_string_data (s, &(s_chars->chars[0]));
+		   : allocate_string_chars_struct (s, fullsize)->chars);
 set_string_length (s, length);
 s->plist = Qnil;
 set_string_byte (s, length, 0);
 POS < 0, resize the string but don't copy any characters.  Use
 this if you're planning on completely overwriting the string.
 */
 void
-resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
+resize_string (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)
-Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
+/* If DELTA < 0, the functions below will delete the characters
-Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
+before POS.  We want to delete characters *after* POS, however,
+so convert this to the appropriate form. */
-if (oldfullsize == newfullsize)
+pos += -delta;
+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))
 	{
-	  /* next simplest case; size change but the necessary
+	  /* Both strings are big.  We can just realloc(). */
-	     allocation size won't change (up or down; code somewhere
+	  set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
-	     depends on there not being any unused allocation space,
+						    string_length (s) + delta + 1));
-	     modulo any alignment constraints). */
 	  if (pos >= 0)
 	    {
 	      Bufbyte *addroff = pos + string_data (s);
 	      memmove (addroff + delta, addroff,
-		       /* +1 due to zero-termination. */
 		       string_length (s) + 1 - pos);
 	    }
 	}
-else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
+else /* String has been demoted from BIG_STRING. */
-	       BIG_STRING_FULLSIZE_P (newfullsize))
 	{
-	  /* next simplest case; the string is big enough to be malloc()ed
+	  Bufbyte *new_data =
-	     itself, so we just realloc.
+	    allocate_string_chars_struct (s, newfullsize)->chars;
+	  Bufbyte *old_data = string_data (s);
-	     It's important not to let the string get below the threshold
-	     for making big strings and still remain malloc()ed; if that
+	  if (pos >= 0)
-	     were the case, repeated calls to this function on the same
+	    {
-	     string could result in memory leakage. */
+	      memcpy (new_data, old_data, pos);
-	  set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
+	      memcpy (new_data + pos + delta, old_data + pos,
-						    newfullsize));
+		      string_length (s) + 1 - pos);
+	    }
+	  set_string_data (s, new_data);
+	  xfree (old_data);
+	}
+}
+else /* old string is small */
+{
+if (oldfullsize == 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). */
 	  if (pos >= 0)
 	    {
 	      Bufbyte *addroff = pos + string_data (s);
 	      memmove (addroff + delta, addroff,
 		       string_length (s) + 1 - pos);
 	    }
 	}
 else
 	{
-	  /* worst case.  We make a new string_chars struct and copy
+	  Bufbyte *old_data = string_data (s);
-	     the string's data into it, inserting/deleting the delta
+	  Bufbyte *new_data =
-	     in the process.  The old string data will either get
+	    BIG_STRING_FULLSIZE_P (newfullsize)
-	     freed by us (if it was malloc()ed) or will be reclaimed
+	    ? xnew_array (Bufbyte, string_length (s) + delta + 1)
-	     in the normal course of garbage collection. */
+	    : allocate_string_chars_struct (s, newfullsize)->chars;
-	  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_addr, old_addr, pos);
+	      memcpy (new_data, old_data, pos);
-	      memcpy (new_addr + pos + delta, old_addr + pos,
+	      memcpy (new_data + pos + delta, old_data + pos,
 		      string_length (s) + 1 - pos);
 	    }
-	  set_string_data (s, new_addr);
+	  set_string_data (s, new_data);
-	  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
-	      /* We need to mark this chunk of the string_chars_block
+	       freak. */
-		 as unused so that compact_string_chars() doesn't
+	    struct string_chars *old_s_chars = (struct string_chars *)
-		 freak. */
+	      ((char *) old_data - offsetof (struct string_chars, chars));
-	      struct string_chars *old_s_chars =
+	    /* Sanity check to make sure we aren't hosed by strange
-		(struct string_chars *) ((char *) old_addr -
+	       alignment/padding. */
-					 sizeof (struct Lisp_String *));
+	    assert (old_s_chars->string == s);
-	      /* Sanity check to make sure we aren't hosed by strange
+	    MARK_STRUCT_AS_FREE (old_s_chars);
-	         alignment/padding. */
+	    ((struct unused_string_chars *) old_s_chars)->fullsize =
-	      assert (old_s_chars->string == s);
+	      oldfullsize;
-	      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.
+set_string_length (s, string_length (s) + delta);
-	 Terminate now just to make sure. */
+/* If pos < 0, the string won't be zero-terminated.
-string_data (s)[string_length (s)] = '\0';
+Terminate now just to make sure. */
+string_data (s)[string_length (s)] = '\0';
-if (pos >= 0)
-	{
+if (pos >= 0)
-	  Lisp_Object string;
+{
+Lisp_Object string;
-	  XSETSTRING (string, s);
-	  /* We also have to adjust all of the extent indices after the
+XSETSTRING (string, s);
-	     place we did the change.  We say "pos - 1" because
+/* We also have to adjust all of the extent indices after the
-	     adjust_extents() is exclusive of the starting position
+	 place we did the change.  We say "pos - 1" because
-	     passed to it. */
+	 adjust_extents() is exclusive of the starting position
-	  adjust_extents (string, pos - 1, string_length (s),
+	 passed to it. */
-			  delta);
+adjust_extents (string, pos - 1, string_length (s),
-	}
+		      delta);
 }
 #ifdef VERIFY_STRING_CHARS_INTEGRITY
 verify_string_chars_integrity ();
 #endif
 }
 #ifdef MULE
 void
-set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
+set_string_char (Lisp_String *s, Charcount i, Emchar c)
 {
 Bufbyte newstr[MAX_EMCHAR_LEN];
 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
 Bytecount newlen = set_charptr_emchar (newstr, c);
 }
 Lisp_Object
 make_string_nocopy (CONST Bufbyte *contents, Bytecount length)
 {
-struct Lisp_String *s;
+Lisp_String *s;
 Lisp_Object val;
 /* Make sure we find out about bad make_string_nocopy's when they happen */
 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
 bytecount_to_charcount (contents, length); /* Just for the assertions */
 #endif
 /* Allocate the string header */
-ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
+ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
 set_lheader_implementation (&(s->lheader), &lrecord_string);
 SET_C_READONLY_RECORD_HEADER (&s->lheader);
 s->plist = Qnil;
 set_string_data (s, (Bufbyte *)contents);
 set_string_length (s, length);
 /* POS is the index of the next string in the block.  */
 while (pos < sb->pos)
 {
 struct string_chars *s_chars =
 (struct string_chars *) &(sb->string_chars[pos]);
-struct Lisp_String *string;
+Lisp_String *string;
 	  int size;
 	  int fullsize;
 	  /* If the string_chars struct is marked as free (i.e. the STRING
 	     pointer is 0xFFFFFFFF) then this is an unused chunk of string
 while (from_pos < from_sb->pos)
 {
 struct string_chars *from_s_chars =
 (struct string_chars *) &(from_sb->string_chars[from_pos]);
 struct string_chars *to_s_chars;
-struct Lisp_String *string;
+Lisp_String *string;
 	  int size;
 	  int fullsize;
 	  /* If the string_chars struct is marked as free (i.e. the STRING
 	     pointer is 0xFFFFFFFF) then this is an unused chunk of string
 #if 1 /* Hack to debug missing purecopy's */
 static int debug_string_purity;
 static void
-debug_string_purity_print (struct Lisp_String *p)
+debug_string_purity_print (Lisp_String *p)
 {
 Charcount i;
 Charcount s = string_char_length (p);
 putc ('\"', stderr);
 for (i = 0; i < s; i++)
 sweep_strings (void)
 {
 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
 int debug = debug_string_purity;
-#define UNMARK_string(ptr)				\
+#define UNMARK_string(ptr) do {			\
-do { struct Lisp_String *p = (ptr);			\
+Lisp_String *p = (ptr);			\
-int size = string_length (p);			\
+size_t size = string_length (p);		\
-UNMARK_RECORD_HEADER (&(p->lheader));		\
+UNMARK_RECORD_HEADER (&(p->lheader));	\
 num_bytes += size;				\
-if (!BIG_STRING_SIZE_P (size))			\
+if (!BIG_STRING_SIZE_P (size))		\
-	 { num_small_bytes += size;			\
+{ num_small_bytes += size;		\
-	   num_small_used++;				\
+num_small_used++;				\
-	 }						\
+}						\
-if (debug) debug_string_purity_print (p);	\
+if (debug)					\
-} while (0)
+debug_string_purity_print (p);		\
-#define ADDITIONAL_FREE_string(p)				\
+} while (0)
-do { int size = string_length (p);				\
+#define ADDITIONAL_FREE_string(ptr) do {	\
-if (BIG_STRING_SIZE_P (size))				\
+size_t size = string_length (ptr);		\
-	 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p)));	\
+if (BIG_STRING_SIZE_P (size))		\
-} while (0)
+xfree (ptr->data);			\
+} while (0)
-SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
+SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
 gc_count_num_short_string_in_use = num_small_used;
 gc_count_string_total_size = num_bytes;
 gc_count_short_string_total_size = num_small_bytes;
 }
 { /* staticpro() */
 int i;
 for (i = 0; i < staticidx; i++)
 mark_object (*(staticvec[i]));
 for (i = 0; i < staticidx_nodump; i++)
 mark_object (*(staticvec_nodump[i]));
 }
 { /* GCPRO() */
 struct gcpro *tail;
 int i;
 *			- nb_staticpro*(relocated Lisp_Object) pointed to by staticpro
 *			- nb_structdmp*pair(void *, adr) for pointers to structures
 *			- lrecord_implementations_table[]
 *			- relocation table
 *                      - wired variable address/value couples with the count preceding the list
 */
 typedef struct
 {
 char signature[8];
 EMACS_UINT stab_offset;
 EMACS_UINT reloc_address;
 while ((e = pdump_hash[pos]) != 0)
 {
 if (e->obj == obj)
 	return;
 pos++;
 if (pos == PDUMP_HASHSIZE)
 	pos = 0;
 }
 }
 pdump_struct_table.list[pdump_struct_table.count].list.first = 0;
 pdump_struct_table.list[pdump_struct_table.count].list.align = 8;
 pdump_struct_table.list[pdump_struct_table.count].list.count = 0;
 pdump_struct_table.list[pdump_struct_table.count].sdesc = sdesc;
 return &pdump_struct_table.list[pdump_struct_table.count++].list;
 }
 static struct {
 Lisp_Object obj;
 	  {
 	    EMACS_INT count = desc[pos].data1;
 	    int i;
 	    if (XD_IS_INDIRECT (count))
 	      count = pdump_get_indirect_count (count, desc, data);
 	    for(i=0;i<count;i++) {
 	      const Lisp_Object *pobj = ((const Lisp_Object *)rdata) + i;
 	      Lisp_Object dobj = *pobj;
 	      backtrace[me].offset = (const char *)pobj - (const char *)data;
 	      pdump_register_object (dobj);
 	    }
 	    break;
 	  }
 	    const struct struct_description *sdesc = desc[pos].data2;
 	    const char *dobj = *(const char **)rdata;
 	    if (dobj) {
 	      if (XD_IS_INDIRECT (count))
 		count = pdump_get_indirect_count (count, desc, data);
 	      pdump_register_struct (dobj, sdesc, count);
 	    }
 	    break;
 	  }
 	default:
 {
 if (!obj ||
 !POINTER_TYPE_P (XTYPE (obj)) ||
 pdump_get_entry (XRECORD_LHEADER (obj)))
 return;
 if (XRECORD_LHEADER_IMPLEMENTATION (obj)->description)
 {
 int me = depth++;
 if (me>65536)
 	{
 	  abort ();
 	}
 backtrace[me].obj = 0;
 backtrace[me].position = 0;
 backtrace[me].offset = 0;
 pdump_add_entry (pdump_get_entry_list (sdesc),
 		       data,
 		       sdesc->size,
 		       count,
 		       0);
 if (desc)
 {
 int pos, i;
 void *rdata;
 memcpy (pdump_buf, elmt->obj, size*count);
 for (i=0; i<count; i++)
 	{
 	  char *cur = ((char *)pdump_buf) + i*size;
 	restart:
 	  for (pos = 0; desc[pos].type != XD_END; pos++)
 		  {
 		    EMACS_INT count = desc[pos].data1;
 		    int i;
 		    if (XD_IS_INDIRECT (count))
 		      count = pdump_get_indirect_count (count, desc, elmt->obj);
 		    for(i=0; i<count; i++)
 		      {
 			Lisp_Object *pobj = ((Lisp_Object *)rdata) + i;
 			Lisp_Object dobj = *pobj;
 			if (dobj && POINTER_TYPE_P (XTYPE (dobj)))
 	{
 	  EMACS_INT count = desc[pos].data1;
 	  int i;
 	  if (XD_IS_INDIRECT (count))
 	    count = pdump_get_indirect_count (count, desc, data);
 	  for (i=0; i<count; i++)
 	    {
 	      Lisp_Object *pobj = ((Lisp_Object *)rdata) + i;
 	      Lisp_Object dobj = *pobj;
 	      if (dobj && POINTER_TYPE_P (XTYPE (dobj)))
 	      {
 		f (elmt, idesc);
 		elmt = elmt->next;
 	      }
 	  }
 for (i=0; i<pdump_struct_table.count; i++)
 	if (pdump_struct_table.list[i].list.align == align) {
 	  elmt = pdump_struct_table.list[i].list.first;
 	  idesc = pdump_struct_table.list[i].sdesc->description;
 	  while (elmt)
 	    {
 	      f (elmt, idesc);
 	      elmt = elmt->next;
 	    }
 	}
 elmt = pdump_opaque_data_list.first;
 while (elmt)
 	{
 	  if (align_table[elmt->size & 255] == align)
 	    f (elmt, 0);
 }
 static void
 pdump_dump_itable (void)
 {
 write (pdump_fd, lrecord_implementations_table, sizeof (lrecord_implementations_table));
 }
 static void
 pdump_dump_rtables (void)
 {
 {
 Lisp_Object obj = pdump_get_entry (XRECORD_LHEADER (*(pdump_wirevec[i])))->save_offset;
 write (pdump_fd, &pdump_wirevec[i], sizeof (pdump_wirevec[i]));
 write (pdump_fd, &obj, sizeof (obj));
 }
 for (i=0; i<pdump_wireidx_list; i++)
 {
 Lisp_Object obj = *(pdump_wirevec_list[i]);
 pdump_entry_list_elmt *elmt;
 EMACS_INT res;
 pdump_object_table[i].count = 0;
 pdump_alert_undump_object[i] = 0;
 }
 pdump_struct_table.count = 0;
 pdump_struct_table.size = -1;
 pdump_opaque_data_list.first = 0;
 pdump_opaque_data_list.align = 8;
 pdump_opaque_data_list.count = 0;
 depth = 0;
 }
 if (!none)
 return;
 for (i=0; i<dumpstructidx; i++)
 pdump_register_struct (*(void **)(dumpstructvec[i].data), dumpstructvec[i].desc, 1);
 memcpy (hd.signature, "XEmacsDP", 8);
 hd.reloc_address = 0;
 hd.nb_staticpro = staticidx;
 hd.nb_structdmp = dumpstructidx;
 hd.last_type    = last_lrecord_type_index_assigned;
 cur_offset = 256;
 max_size = 0;
 pdump_scan_by_alignement (pdump_allocate_offset);
 pdump_qnil = pdump_get_entry (XRECORD_LHEADER (Qnil));
 pdump_buf = malloc (max_size);
 pdump_fd = open ("xemacs.dmp", O_WRONLY|O_CREAT|O_TRUNC, 0666);
 #ifdef HAVE_MMAP
 pdump_start = mmap (0, length, PROT_READ|PROT_WRITE, MAP_PRIVATE, pdump_fd, 0);
 if (pdump_start == MAP_FAILED)
 pdump_start = 0;
 #endif
 if (!pdump_start)
 {
 pdump_start = (void *)((((unsigned long)(malloc(length+255))) + 255) & ~255);
 read(pdump_fd, pdump_start, length);
 }

Mercurial > hg > xemacs-beta

comparison src/alloc.c @ 438:84b14dcb0985 r21-2-27