]> code.delx.au - gnu-emacs/blobdiff - src/alloc.c
*** empty log message ***
[gnu-emacs] / src / alloc.c
index e3b65c1a4f463b50eec3f228e9a829511e1b9284..5cf22eb62e77ee318dcb96afb69b5eb90cead1cf 100644 (file)
@@ -1,6 +1,6 @@
 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
    Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
-      2000, 2001, 2002, 2003, 2004, 2005, 2006  Free Software Foundation, Inc.
+      2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007  Free Software Foundation, Inc.
 
 This file is part of GNU Emacs.
 
@@ -23,6 +23,10 @@ Boston, MA 02110-1301, USA.  */
 #include <stdio.h>
 #include <limits.h>            /* For CHAR_BIT.  */
 
+#ifdef STDC_HEADERS
+#include <stddef.h>            /* For offsetof, used by PSEUDOVECSIZE. */
+#endif
+
 #ifdef ALLOC_DEBUG
 #undef INLINE
 #endif
@@ -74,6 +78,11 @@ extern POINTER_TYPE *sbrk ();
 #define O_WRONLY 1
 #endif
 
+#ifdef WINDOWSNT
+#include <fcntl.h>
+#include "w32.h"
+#endif
+
 #ifdef DOUG_LEA_MALLOC
 
 #include <malloc.h>
@@ -118,21 +127,21 @@ extern __malloc_size_t __malloc_extra_blocks;
 
 static pthread_mutex_t alloc_mutex;
 
-#define BLOCK_INPUT_ALLOC                       \
-  do                                            \
-    {                                           \
-      pthread_mutex_lock (&alloc_mutex);        \
-      if (pthread_self () == main_thread)       \
-        BLOCK_INPUT;                            \
-    }                                           \
+#define BLOCK_INPUT_ALLOC                               \
+  do                                                    \
+    {                                                   \
+      if (pthread_equal (pthread_self (), main_thread)) \
+        BLOCK_INPUT;                                   \
+      pthread_mutex_lock (&alloc_mutex);                \
+    }                                                   \
   while (0)
-#define UNBLOCK_INPUT_ALLOC                     \
-  do                                            \
-    {                                           \
-      if (pthread_self () == main_thread)       \
-        UNBLOCK_INPUT;                          \
-      pthread_mutex_unlock (&alloc_mutex);      \
-    }                                           \
+#define UNBLOCK_INPUT_ALLOC                             \
+  do                                                    \
+    {                                                   \
+      pthread_mutex_unlock (&alloc_mutex);              \
+      if (pthread_equal (pthread_self (), main_thread)) \
+        UNBLOCK_INPUT;                                 \
+    }                                                   \
   while (0)
 
 #else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
@@ -285,10 +294,18 @@ static size_t pure_bytes_used_before_overflow;
       && ((PNTR_COMPARISON_TYPE) (P)                           \
          >= (PNTR_COMPARISON_TYPE) purebeg))
 
-/* Index in pure at which next pure object will be allocated.. */
+/* Total number of bytes allocated in pure storage. */
 
 EMACS_INT pure_bytes_used;
 
+/* Index in pure at which next pure Lisp object will be allocated.. */
+
+static EMACS_INT pure_bytes_used_lisp;
+
+/* Number of bytes allocated for non-Lisp objects in pure storage.  */
+
+static EMACS_INT pure_bytes_used_non_lisp;
+
 /* If nonzero, this is a warning delivered by malloc and not yet
    displayed.  */
 
@@ -461,7 +478,7 @@ static int live_symbol_p P_ ((struct mem_node *, void *));
 static int live_float_p P_ ((struct mem_node *, void *));
 static int live_misc_p P_ ((struct mem_node *, void *));
 static void mark_maybe_object P_ ((Lisp_Object));
-static void mark_memory P_ ((void *, void *));
+static void mark_memory P_ ((void *, void *, int));
 static void mem_init P_ ((void));
 static struct mem_node *mem_insert P_ ((void *, void *, enum mem_type));
 static void mem_insert_fixup P_ ((struct mem_node *));
@@ -555,8 +572,7 @@ buffer_memory_full ()
 
   /* 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);
+  xsignal (Qnil, Vmemory_signal_data);
 }
 
 
@@ -2773,7 +2789,14 @@ check_cons_list ()
 #endif
 }
 
-/* Make a list of 2, 3, 4 or 5 specified objects.  */
+/* Make a list of 1, 2, 3, 4 or 5 specified objects.  */
+
+Lisp_Object
+list1 (arg1)
+     Lisp_Object arg1;
+{
+  return Fcons (arg1, Qnil);
+}
 
 Lisp_Object
 list2 (arg1, arg2)
@@ -3003,13 +3026,17 @@ allocate_frame ()
 struct Lisp_Process *
 allocate_process ()
 {
-  EMACS_INT len = VECSIZE (struct Lisp_Process);
-  struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_PROCESS);
+  /* Memory-footprint of the object in nb of Lisp_Object fields.  */
+  EMACS_INT memlen = VECSIZE (struct Lisp_Process);
+  /* Size if we only count the actual Lisp_Object fields (which need to be
+     traced by the GC).  */
+  EMACS_INT lisplen = PSEUDOVECSIZE (struct Lisp_Process, pid);
+  struct Lisp_Vector *v = allocate_vectorlike (memlen, MEM_TYPE_PROCESS);
   EMACS_INT i;
 
-  for (i = 0; i < len; ++i)
+  for (i = 0; i < lisplen; ++i)
     v->contents[i] = Qnil;
-  v->size = len;
+  v->size = lisplen;
 
   return (struct Lisp_Process *) v;
 }
@@ -3485,8 +3512,7 @@ memory_full ()
 
   /* 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);
+  xsignal (Qnil, Vmemory_signal_data);
 }
 
 /* If we released our reserve (due to running out of memory),
@@ -4301,11 +4327,13 @@ mark_maybe_pointer (p)
 }
 
 
-/* Mark Lisp objects referenced from the address range START..END.  */
+/* Mark Lisp objects referenced from the address range START+OFFSET..END
+   or END+OFFSET..START. */
 
 static void
-mark_memory (start, end)
+mark_memory (start, end, offset)
      void *start, *end;
+     int offset;
 {
   Lisp_Object *p;
   void **pp;
@@ -4324,7 +4352,7 @@ mark_memory (start, end)
     }
 
   /* Mark Lisp_Objects.  */
-  for (p = (Lisp_Object *) start; (void *) p < end; ++p)
+  for (p = (Lisp_Object *) ((char *) start + offset); (void *) p < end; ++p)
     mark_maybe_object (*p);
 
   /* Mark Lisp data pointed to.  This is necessary because, in some
@@ -4345,7 +4373,7 @@ mark_memory (start, end)
      away.  The only reference to the life string is through the
      pointer `s'.  */
 
-  for (pp = (void **) start; (void *) pp < end; ++pp)
+  for (pp = (void **) ((char *) start + offset); (void *) pp < end; ++pp)
     mark_maybe_pointer (*pp);
 }
 
@@ -4524,7 +4552,11 @@ static void
 mark_stack ()
 {
   int i;
-  jmp_buf j;
+  /* jmp_buf may not be aligned enough on darwin-ppc64 */
+  union aligned_jmpbuf {
+    Lisp_Object o;
+    jmp_buf j;
+  } j;
   volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
   void *end;
 
@@ -4555,7 +4587,7 @@ mark_stack ()
     }
 #endif /* GC_SETJMP_WORKS */
 
-  setjmp (j);
+  setjmp (j.j);
   end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
 
@@ -4570,7 +4602,7 @@ mark_stack ()
 #endif
 #endif
   for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT)
-    mark_memory ((char *) stack_base + i, end);
+    mark_memory (stack_base, end, i);
   /* Allow for marking a secondary stack, like the register stack on the
      ia64.  */
 #ifdef GC_MARK_SECONDARY_STACK
@@ -4585,6 +4617,32 @@ mark_stack ()
 #endif /* GC_MARK_STACK != 0 */
 
 
+/* Determine whether it is safe to access memory at address P.  */
+int
+valid_pointer_p (p)
+     void *p;
+{
+#ifdef WINDOWSNT
+  return w32_valid_pointer_p (p, 16);
+#else
+  int fd;
+
+  /* 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;
+#endif
+}
 
 /* Return 1 if OBJ is a valid lisp object.
    Return 0 if OBJ is NOT a valid lisp object.
@@ -4597,9 +4655,7 @@ valid_lisp_object_p (obj)
      Lisp_Object obj;
 {
   void *p;
-#if !GC_MARK_STACK
-  int fd;
-#else
+#if GC_MARK_STACK
   struct mem_node *m;
 #endif
 
@@ -4611,26 +4667,22 @@ valid_lisp_object_p (obj)
     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;
+  return valid_pointer_p (p);
 #else
 
   m = mem_find (p);
 
   if (m == MEM_NIL)
-    return 0;
+    {
+      int valid = valid_pointer_p (p);
+      if (valid <= 0)
+       return valid;
+
+      if (SUBRP (obj))
+       return 1;
+
+      return 0;
+    }
 
   switch (m->type)
     {
@@ -4679,10 +4731,7 @@ valid_lisp_object_p (obj)
 
 /* Allocate room for SIZE bytes from pure Lisp storage and return a
    pointer to it.  TYPE is the Lisp type for which the memory is
-   allocated.  TYPE < 0 means it's not used for a Lisp object.
-
-   If store_pure_type_info is set and TYPE is >= 0, the type of
-   the allocated object is recorded in pure_types.  */
+   allocated.  TYPE < 0 means it's not used for a Lisp object.  */
 
 static POINTER_TYPE *
 pure_alloc (size, type)
@@ -4707,8 +4756,21 @@ pure_alloc (size, type)
 #endif
 
  again:
-  result = ALIGN (purebeg + pure_bytes_used, alignment);
-  pure_bytes_used = ((char *)result - (char *)purebeg) + size;
+  if (type >= 0)
+    {
+      /* Allocate space for a Lisp object from the beginning of the free
+        space with taking account of alignment.  */
+      result = ALIGN (purebeg + pure_bytes_used_lisp, alignment);
+      pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
+    }
+  else
+    {
+      /* Allocate space for a non-Lisp object from the end of the free
+        space.  */
+      pure_bytes_used_non_lisp += size;
+      result = purebeg + pure_size - pure_bytes_used_non_lisp;
+    }
+  pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
 
   if (pure_bytes_used <= pure_size)
     return result;
@@ -4720,6 +4782,7 @@ pure_alloc (size, type)
   pure_size = 10000;
   pure_bytes_used_before_overflow += pure_bytes_used - size;
   pure_bytes_used = 0;
+  pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
   goto again;
 }
 
@@ -4735,6 +4798,73 @@ check_pure_size ()
 }
 
 
+/* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
+   the non-Lisp data pool of the pure storage, and return its start
+   address.  Return NULL if not found.  */
+
+static char *
+find_string_data_in_pure (data, nbytes)
+     char *data;
+     int nbytes;
+{
+  int i, skip, bm_skip[256], last_char_skip, infinity, start, start_max;
+  unsigned char *p;
+  char *non_lisp_beg;
+
+  if (pure_bytes_used_non_lisp < nbytes + 1)
+    return NULL;
+
+  /* Set up the Boyer-Moore table.  */
+  skip = nbytes + 1;
+  for (i = 0; i < 256; i++)
+    bm_skip[i] = skip;
+
+  p = (unsigned char *) data;
+  while (--skip > 0)
+    bm_skip[*p++] = skip;
+
+  last_char_skip = bm_skip['\0'];
+
+  non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp;
+  start_max = pure_bytes_used_non_lisp - (nbytes + 1);
+
+  /* See the comments in the function `boyer_moore' (search.c) for the
+     use of `infinity'.  */
+  infinity = pure_bytes_used_non_lisp + 1;
+  bm_skip['\0'] = infinity;
+
+  p = (unsigned char *) non_lisp_beg + nbytes;
+  start = 0;
+  do
+    {
+      /* Check the last character (== '\0').  */
+      do
+       {
+         start += bm_skip[*(p + start)];
+       }
+      while (start <= start_max);
+
+      if (start < infinity)
+       /* Couldn't find the last character.  */
+       return NULL;
+
+      /* No less than `infinity' means we could find the last
+        character at `p[start - infinity]'.  */
+      start -= infinity;
+
+      /* Check the remaining characters.  */
+      if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
+       /* Found.  */
+       return non_lisp_beg + start;
+
+      start += last_char_skip;
+    }
+  while (start <= start_max);
+
+  return NULL;
+}
+
+
 /* Return a string allocated in pure space.  DATA is a buffer holding
    NCHARS characters, and NBYTES bytes of string data.  MULTIBYTE
    non-zero means make the result string multibyte.
@@ -4753,11 +4883,15 @@ make_pure_string (data, nchars, nbytes, multibyte)
   struct Lisp_String *s;
 
   s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
-  s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
+  s->data = find_string_data_in_pure (data, nbytes);
+  if (s->data == NULL)
+    {
+      s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
+      bcopy (data, s->data, nbytes);
+      s->data[nbytes] = '\0';
+    }
   s->size = nchars;
   s->size_byte = multibyte ? nbytes : -1;
-  bcopy (data, s->data, nbytes);
-  s->data[nbytes] = '\0';
   s->intervals = NULL_INTERVAL;
   XSETSTRING (string, s);
   return string;
@@ -5558,6 +5692,10 @@ mark_object (arg)
          if (size & PSEUDOVECTOR_FLAG)
            size &= PSEUDOVECTOR_SIZE_MASK;
 
+         /* Note that this size is not the memory-footprint size, but only
+            the number of Lisp_Object fields that we should trace.
+            The distinction is used e.g. by Lisp_Process which places extra
+            non-Lisp_Object fields at the end of the structure.  */
          for (i = 0; i < size; i++) /* and then mark its elements */
            mark_object (ptr->contents[i]);
        }
@@ -6208,6 +6346,7 @@ init_alloc_once ()
   purebeg = PUREBEG;
   pure_size = PURESIZE;
   pure_bytes_used = 0;
+  pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
   pure_bytes_used_before_overflow = 0;
 
   /* Initialize the list of free aligned blocks.  */