emacs: src/alloc.c comparison

comparison src/alloc.c @ 90261:7beb78bc1f8e

Revision: miles@gnu.org--gnu-2005/emacs--unicode--0--patch-97 Merge from emacs--cvs-trunk--0 Patches applied: * emacs--cvs-trunk--0 (patch 616-696) - Add lisp/mh-e/.arch-inventory - Update from CVS - Merge from gnus--rel--5.10 - Update from CVS: lisp/smerge-mode.el: Add 'tools' to file keywords. - lisp/gnus/ChangeLog: Remove duplicate entry * gnus--rel--5.10 (patch 147-181) - Update from CVS - Merge from emacs--cvs-trunk--0 - Update from CVS: lisp/mml.el (mml-preview): Doc fix. - Update from CVS: texi/message.texi: Fix default values. - Update from CVS: texi/gnus.texi (RSS): Addition.

author	Miles Bader <miles@gnu.org>
date	Mon, 16 Jan 2006 08:37:27 +0000
parents	aa89c814f853 28fd92314a04
children	5b7d410e31f9

comparison

equal deleted inserted replaced

-:0ca0d9181b5e
+:7beb78bc1f8e
 #ifdef HAVE_UNISTD_H
 #include <unistd.h>
 #else
 extern POINTER_TYPE *sbrk ();
+#endif
+#ifdef HAVE_FCNTL_H
+#define INCLUDED_FCNTL
+#include <fcntl.h>
+#endif
+#ifndef O_WRONLY
+#define O_WRONLY 1
 #endif
 #ifdef DOUG_LEA_MALLOC
 #include <malloc.h>
 /* Value of _bytes_used, when spare_memory was freed.  */
 static __malloc_size_t bytes_used_when_full;
+static __malloc_size_t bytes_used_when_reconsidered;
 /* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
 to a struct Lisp_String.  */
 #define MARK_STRING(S)		((S)->size |= ARRAY_MARK_FLAG)
 #define UNMARK_STRING(S)	((S)->size &= ~ARRAY_MARK_FLAG)
 EMACS_INT gc_relative_threshold;
 static Lisp_Object Vgc_cons_percentage;
+/* Minimum number of bytes of consing since GC before next GC,
+when memory is full.  */
+EMACS_INT memory_full_cons_threshold;
 /* Nonzero during GC.  */
 int gc_in_progress;
 /* Nonzero means abort if try to GC.
 static int total_conses, total_markers, total_symbols, total_vector_size;
 static int total_free_conses, total_free_markers, total_free_symbols;
 static int total_free_floats, total_floats;
 /* Points to memory space allocated as "spare", to be freed if we run
-out of memory.  */
+out of memory.  We keep one large block, four cons-blocks, and
+two string blocks.  */
-static char *spare_memory;
+char *spare_memory[7];
-/* Amount of spare memory to keep in reserve.  */
+/* Amount of spare memory to keep in large reserve block.  */
 #define SPARE_MEMORY (1 << 14)
 /* Number of extra blocks malloc should get when it needs more core.  */
 MEM_TYPE_PROCESS,
 MEM_TYPE_HASH_TABLE,
 MEM_TYPE_FRAME,
 MEM_TYPE_WINDOW
 };
+static POINTER_TYPE *lisp_align_malloc P_ ((size_t, enum mem_type));
+static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
+void refill_memory_reserve ();
 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
 #include <stdio.h>		/* For fprintf.  */
 static void mem_rotate_right P_ ((struct mem_node *));
 static void mem_delete P_ ((struct mem_node *));
 static void mem_delete_fixup P_ ((struct mem_node *));
 static INLINE struct mem_node *mem_find P_ ((void *));
 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
 static void check_gcpros P_ ((void));
 #endif
 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
 pending_malloc_warning = 0;
 }
 #ifdef DOUG_LEA_MALLOC
-#  define BYTES_USED (mallinfo ().arena)
+#  define BYTES_USED (mallinfo ().uordblks)
 #else
 #  define BYTES_USED _bytes_used
 #endif
-/* Called if malloc returns zero.  */
-void
-memory_full ()
-{
-Vmemory_full = Qt;
-#ifndef SYSTEM_MALLOC
-bytes_used_when_full = BYTES_USED;
-#endif
-/* The first time we get here, free the spare memory.  */
-if (spare_memory)
-{
-free (spare_memory);
-spare_memory = 0;
-}
-/* This used to call error, but if we've run out of memory, we could
-get infinite recursion trying to build the string.  */
-while (1)
-Fsignal (Qnil, Vmemory_signal_data);
-}
-DEFUN ("memory-full-p", Fmemory_full_p, Smemory_full_p, 0, 0, 0,
-doc: /* t if memory is nearly full, nil otherwise.  */)
-()
-{
-return (spare_memory ? Qnil : Qt);
-}
-/* If we released our reserve (due to running out of memory),
-and we have a fair amount free once again,
-try to set aside another reserve in case we run out once more.
-This is called when a relocatable block is freed in ralloc.c.  */
-void
-refill_memory_reserve ()
-{
-#ifndef SYSTEM_MALLOC
-if (spare_memory == 0)
-spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);
-#endif
-}
 /* Called if we can't allocate relocatable space for a buffer.  */
 void
 buffer_memory_full ()
 malloc.  */
 #ifndef REL_ALLOC
 memory_full ();
 #endif
-Vmemory_full = Qt;
 /* This used to call error, but if we've run out of memory, we could
 get infinite recursion trying to build the string.  */
 while (1)
 Fsignal (Qnil, Vmemory_signal_data);
 POINTER_TYPE *block;
 {
 BLOCK_INPUT;
 free (block);
 UNBLOCK_INPUT;
+/* We don't call refill_memory_reserve here
+because that duplicates doing so in emacs_blocked_free
+and the criterion should go there.  */
 }
 /* Like strdup, but uses xmalloc.  */
 static void
 emacs_blocked_free (ptr, ptr2)
 void *ptr;
 const void *ptr2;
 {
+EMACS_INT bytes_used_now;
 BLOCK_INPUT_ALLOC;
 #ifdef GC_MALLOC_CHECK
 if (ptr)
 {
 free (ptr);
 /* If we released our reserve (due to running out of memory),
 and we have a fair amount free once again,
 try to set aside another reserve in case we run out once more.  */
-if (spare_memory == 0
+if (! NILP (Vmemory_full)
 /* Verify there is enough space that even with the malloc
 	 hysteresis this call won't run out again.
 	 The code here is correct as long as SPARE_MEMORY
 	 is substantially larger than the block size malloc uses.  */
 && (bytes_used_when_full
-	  > BYTES_USED + max (malloc_hysteresis, 4) * SPARE_MEMORY))
+	  > ((bytes_used_when_reconsidered = BYTES_USED)
-spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);
+	     + max (malloc_hysteresis, 4) * SPARE_MEMORY)))
+refill_memory_reserve ();
 __free_hook = emacs_blocked_free;
 UNBLOCK_INPUT_ALLOC;
 }
 void
 free_float (ptr)
 struct Lisp_Float *ptr;
 {
-*(struct Lisp_Float **)&ptr->data = float_free_list;
+ptr->u.chain = float_free_list;
 float_free_list = ptr;
 }
 /* Return a new float object with value FLOAT_VALUE.  */
 if (float_free_list)
 {
 /* We use the data field for chaining the free list
 	 so that we won't use the same field that has the mark bit.  */
 XSETFLOAT (val, float_free_list);
-float_free_list = *(struct Lisp_Float **)&float_free_list->data;
+float_free_list = float_free_list->u.chain;
 }
 else
 {
 if (float_block_index == FLOAT_BLOCK_SIZE)
 	{
 void
 free_cons (ptr)
 struct Lisp_Cons *ptr;
 {
-*(struct Lisp_Cons **)&ptr->cdr = cons_free_list;
+ptr->u.chain = cons_free_list;
 #if GC_MARK_STACK
 ptr->car = Vdead;
 #endif
 cons_free_list = ptr;
 }
 if (cons_free_list)
 {
 /* We use the cdr for chaining the free list
 	 so that we won't use the same field that has the mark bit.  */
 XSETCONS (val, cons_free_list);
-cons_free_list = *(struct Lisp_Cons **)&cons_free_list->cdr;
+cons_free_list = cons_free_list->u.chain;
 }
 else
 {
 if (cons_block_index == CONS_BLOCK_SIZE)
 	{
 {
 #ifdef GC_CHECK_CONS_LIST
 struct Lisp_Cons *tail = cons_free_list;
 while (tail)
-tail = *(struct Lisp_Cons **)&tail->cdr;
+tail = tail->u.chain;
 #endif
 }
 /* Make a list of 2, 3, 4 or 5 specified objects.  */
 CHECK_STRING (name);
 if (symbol_free_list)
 {
 XSETSYMBOL (val, symbol_free_list);
-symbol_free_list = *(struct Lisp_Symbol **)&symbol_free_list->value;
+symbol_free_list = symbol_free_list->next;
 }
 else
 {
 if (symbol_block_index == SYMBOL_BLOCK_SIZE)
 	{
 return result;
 }
 }
+/************************************************************************
+			   Memory Full Handling
+************************************************************************/
+/* Called if malloc returns zero.  */
+void
+memory_full ()
+{
+int i;
+Vmemory_full = Qt;
+memory_full_cons_threshold = sizeof (struct cons_block);
+/* The first time we get here, free the spare memory.  */
+for (i = 0; i < sizeof (spare_memory) / sizeof (char *); i++)
+if (spare_memory[i])
+{
+	if (i == 0)
+	  free (spare_memory[i]);
+	else if (i >= 1 && i <= 4)
+	  lisp_align_free (spare_memory[i]);
+	else
+	  lisp_free (spare_memory[i]);
+	spare_memory[i] = 0;
+}
+/* Record the space now used.  When it decreases substantially,
+we can refill the memory reserve.  */
+#ifndef SYSTEM_MALLOC
+bytes_used_when_full = BYTES_USED;
+#endif
+/* This used to call error, but if we've run out of memory, we could
+get infinite recursion trying to build the string.  */
+while (1)
+Fsignal (Qnil, Vmemory_signal_data);
+}
+/* If we released our reserve (due to running out of memory),
+and we have a fair amount free once again,
+try to set aside another reserve in case we run out once more.
+This is called when a relocatable block is freed in ralloc.c,
+and also directly from this file, in case we're not using ralloc.c.  */
+void
+refill_memory_reserve ()
+{
+#ifndef SYSTEM_MALLOC
+if (spare_memory[0] == 0)
+spare_memory[0] = (char *) malloc ((size_t) SPARE_MEMORY);
+if (spare_memory[1] == 0)
+spare_memory[1] = (char *) lisp_align_malloc (sizeof (struct cons_block),
+						  MEM_TYPE_CONS);
+if (spare_memory[2] == 0)
+spare_memory[2] = (char *) lisp_align_malloc (sizeof (struct cons_block),
+						  MEM_TYPE_CONS);
+if (spare_memory[3] == 0)
+spare_memory[3] = (char *) lisp_align_malloc (sizeof (struct cons_block),
+						  MEM_TYPE_CONS);
+if (spare_memory[4] == 0)
+spare_memory[4] = (char *) lisp_align_malloc (sizeof (struct cons_block),
+						  MEM_TYPE_CONS);
+if (spare_memory[5] == 0)
+spare_memory[5] = (char *) lisp_malloc (sizeof (struct string_block),
+					    MEM_TYPE_STRING);
+if (spare_memory[6] == 0)
+spare_memory[6] = (char *) lisp_malloc (sizeof (struct string_block),
+					    MEM_TYPE_STRING);
+if (spare_memory[0] && spare_memory[1] && spare_memory[5])
+Vmemory_full = Qnil;
+#endif
+}
 /************************************************************************
 			   C Stack Marking
 ************************************************************************/
 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
 check_gcpros ();
 #endif
 }
 #endif /* GC_MARK_STACK != 0 */
+/* Return 1 if OBJ is a valid lisp object.
+Return 0 if OBJ is NOT a valid lisp object.
+Return -1 if we cannot validate OBJ.
+This function can be quite slow,
+so it should only be used in code for manual debugging.  */
+int
+valid_lisp_object_p (obj)
+Lisp_Object obj;
+{
+void *p;
+#if !GC_MARK_STACK
+int fd;
+#else
+struct mem_node *m;
+#endif
+if (INTEGERP (obj))
+return 1;
+p = (void *) XPNTR (obj);
+if (PURE_POINTER_P (p))
+return 1;
+#if !GC_MARK_STACK
+/* We need to determine whether it is safe to access memory at
+address P.  Obviously, we cannot just access it (we would SEGV
+trying), so we trick the o/s to tell us whether p is a valid
+pointer.  Unfortunately, we cannot use NULL_DEVICE here, as
+emacs_write may not validate p in that case.  */
+if ((fd = emacs_open ("__Valid__Lisp__Object__", O_CREAT | O_WRONLY | O_TRUNC, 0666)) >= 0)
+{
+int valid = (emacs_write (fd, (char *)p, 16) == 16);
+emacs_close (fd);
+unlink ("__Valid__Lisp__Object__");
+return valid;
+}
+return -1;
+#else
+m = mem_find (p);
+if (m == MEM_NIL)
+return 0;
+switch (m->type)
+{
+case MEM_TYPE_NON_LISP:
+return 0;
+case MEM_TYPE_BUFFER:
+return live_buffer_p (m, p);
+case MEM_TYPE_CONS:
+return live_cons_p (m, p);
+case MEM_TYPE_STRING:
+return live_string_p (m, p);
+case MEM_TYPE_MISC:
+return live_misc_p (m, p);
+case MEM_TYPE_SYMBOL:
+return live_symbol_p (m, p);
+case MEM_TYPE_FLOAT:
+return live_float_p (m, p);
+case MEM_TYPE_VECTOR:
+case MEM_TYPE_PROCESS:
+case MEM_TYPE_HASH_TABLE:
+case MEM_TYPE_FRAME:
+case MEM_TYPE_WINDOW:
+return live_vector_p (m, p);
+default:
+break;
+}
+return 0;
+#endif
+}
 /***********************************************************************
 		       Pure Storage Management
 total += total_string_size;
 total += total_vector_size * sizeof (Lisp_Object);
 total += total_floats  * sizeof (struct Lisp_Float);
 total += total_intervals * sizeof (struct interval);
 total += total_strings * sizeof (struct Lisp_String);
 gc_relative_threshold = total * XFLOAT_DATA (Vgc_cons_percentage);
 }
 else
 gc_relative_threshold = 0;
 	register struct Lisp_Cons *ptr = XCONS (obj);
 	if (CONS_MARKED_P (ptr)) break;
 	CHECK_ALLOCATED_AND_LIVE (live_cons_p);
 	CONS_MARK (ptr);
 	/* If the cdr is nil, avoid recursion for the car.  */
-	if (EQ (ptr->cdr, Qnil))
+	if (EQ (ptr->u.cdr, Qnil))
 	  {
 	    obj = ptr->car;
 	    cdr_count = 0;
 	    goto loop;
 	  }
 	mark_object (ptr->car);
-	obj = ptr->cdr;
+	obj = ptr->u.cdr;
 	cdr_count++;
 	if (cdr_count == mark_object_loop_halt)
 	  abort ();
 	goto loop;
 }
 	int this_free = 0;
 	for (i = 0; i < lim; i++)
 	  if (!CONS_MARKED_P (&cblk->conses[i]))
 	    {
 	      this_free++;
-	      *(struct Lisp_Cons **)&cblk->conses[i].cdr = cons_free_list;
+	      cblk->conses[i].u.chain = cons_free_list;
 	      cons_free_list = &cblk->conses[i];
 #if GC_MARK_STACK
 	      cons_free_list->car = Vdead;
 #endif
 	    }
 	   this block.  */
 	if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
 	  {
 	    *cprev = cblk->next;
 	    /* Unhook from the free list.  */
-	    cons_free_list = *(struct Lisp_Cons **) &cblk->conses[0].cdr;
+	    cons_free_list = cblk->conses[0].u.chain;
 	    lisp_align_free (cblk);
 	    n_cons_blocks--;
 	  }
 	else
 	  {
 	int this_free = 0;
 	for (i = 0; i < lim; i++)
 	  if (!FLOAT_MARKED_P (&fblk->floats[i]))
 	    {
 	      this_free++;
-	      *(struct Lisp_Float **)&fblk->floats[i].data = float_free_list;
+	      fblk->floats[i].u.chain = float_free_list;
 	      float_free_list = &fblk->floats[i];
 	    }
 	  else
 	    {
 	      num_used++;
 	   this block.  */
 	if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
 	  {
 	    *fprev = fblk->next;
 	    /* Unhook from the free list.  */
-	    float_free_list = *(struct Lisp_Float **) &fblk->floats[0].data;
+	    float_free_list = fblk->floats[0].u.chain;
 	    lisp_align_free (fblk);
 	    n_float_blocks--;
 	  }
 	else
 	  {
 	       so we conservatively assume that it is live.  */
 	    int pure_p = PURE_POINTER_P (XSTRING (sym->xname));
 	    if (!sym->gcmarkbit && !pure_p)
 	      {
-		*(struct Lisp_Symbol **) &sym->value = symbol_free_list;
+		sym->next = symbol_free_list;
 		symbol_free_list = sym;
 #if GC_MARK_STACK
 		symbol_free_list->function = Vdead;
 #endif
 		++this_free;
 	   this block.  */
 	if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
 	  {
 	    *sprev = sblk->next;
 	    /* Unhook from the free list.  */
-	    symbol_free_list = *(struct Lisp_Symbol **)&sblk->symbols[0].value;
+	    symbol_free_list = sblk->symbols[0].next;
 	    lisp_free (sblk);
 	    n_symbol_blocks--;
 	  }
 	else
 	  {
 malloc_hysteresis = 32;
 #else
 malloc_hysteresis = 0;
 #endif
-spare_memory = (char *) malloc (SPARE_MEMORY);
+refill_memory_reserve ();
 ignore_warnings = 0;
 gcprolist = 0;
 byte_stack_list = 0;
 staticidx = 0;
 Vmemory_signal_data
 = list2 (Qerror,
 	     build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
 DEFVAR_LISP ("memory-full", &Vmemory_full,
-	       doc: /* Non-nil means we are handling a memory-full error.  */);
+	       doc: /* Non-nil means Emacs cannot get much more Lisp memory.  */);
 Vmemory_full = Qnil;
 staticpro (&Qgc_cons_threshold);
 Qgc_cons_threshold = intern ("gc-cons-threshold");
 	       doc: /* Accumulated time elapsed in garbage collections.
 The time is in seconds as a floating point value.  */);
 DEFVAR_INT ("gcs-done", &gcs_done,
 	      doc: /* Accumulated number of garbage collections done.  */);
-defsubr (&Smemory_full_p);
 defsubr (&Scons);
 defsubr (&Slist);
 defsubr (&Svector);
 defsubr (&Smake_byte_code);
 defsubr (&Smake_list);

Mercurial > emacs

comparison src/alloc.c @ 90261:7beb78bc1f8e