Merge remote-tracking branch 'savannah/master' into HEAD

1 files changed, 197 insertions, 153 deletions

diff --git a/src/alloc.c b/src/alloc.c
index 281525b20e5..9a9dbb52e7b 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -4445,7 +4445,7 @@ mem_delete_fixup (struct mem_node *x)
 
 
 /* If P is a pointer into a live Lisp string object on the heap,
-   return the object.  Otherwise, return nil.  M is a pointer to the
+   return the object's address.  Otherwise, return NULL.  M points to the
    mem_block for P.
 
    This and other *_holding functions look for a pointer anywhere into
@@ -4453,103 +4453,97 @@ mem_delete_fixup (struct mem_node *x)
    because some compilers sometimes optimize away the latter.  See
    Bug#28213.  */
 
-static Lisp_Object
+static struct Lisp_String *
 live_string_holding (struct mem_node *m, void *p)
 {
-  if (m->type == MEM_TYPE_STRING)
-    {
-      struct string_block *b = m->start;
-      char *cp = p;
-      ptrdiff_t offset = cp - (char *) &b->strings[0];
+  eassert (m->type == MEM_TYPE_STRING);
+  struct string_block *b = m->start;
+  char *cp = p;
+  ptrdiff_t offset = cp - (char *) &b->strings[0];
 
-      /* P must point into a Lisp_String structure, and it
-         must not be on the free-list.  */
-      if (0 <= offset && offset < sizeof b->strings)
-        {
-          cp = ptr_bounds_copy (cp, b);
-          struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0];
-          if (s->u.s.data)
-            return make_lisp_ptr (s, Lisp_String);
-        }
+  /* P must point into a Lisp_String structure, and it
+     must not be on the free-list.  */
+  if (0 <= offset && offset < sizeof b->strings)
+    {
+      cp = ptr_bounds_copy (cp, b);
+      struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0];
+      if (s->u.s.data)
+        return s;
     }
-  return Qnil;
+  return NULL;
 }
 
 static bool
 live_string_p (struct mem_node *m, void *p)
 {
-  return !NILP (live_string_holding (m, p));
+  return live_string_holding (m, p) == p;
 }
 
 /* If P is a pointer into a live Lisp cons object on the heap, return
-   the object.  Otherwise, return nil.  M is a pointer to the
+   the object's address.  Otherwise, return NULL.  M points to the
    mem_block for P.  */
 
-static Lisp_Object
+static struct Lisp_Cons *
 live_cons_holding (struct mem_node *m, void *p)
 {
-  if (m->type == MEM_TYPE_CONS)
+  eassert (m->type == MEM_TYPE_CONS);
+  struct cons_block *b = m->start;
+  char *cp = p;
+  ptrdiff_t offset = cp - (char *) &b->conses[0];
+
+  /* P must point into a Lisp_Cons, not be
+     one of the unused cells in the current cons block,
+     and not be on the free-list.  */
+  if (0 <= offset && offset < sizeof b->conses
+      && (b != cons_block
+          || offset / sizeof b->conses[0] < cons_block_index))
     {
-      struct cons_block *b = m->start;
-      char *cp = p;
-      ptrdiff_t offset = cp - (char *) &b->conses[0];
-
-      /* P must point into a Lisp_Cons, not be
-         one of the unused cells in the current cons block,
-         and not be on the free-list.  */
-      if (0 <= offset && offset < sizeof b->conses
-          && (b != cons_block
-              || offset / sizeof b->conses[0] < cons_block_index))
-        {
-          cp = ptr_bounds_copy (cp, b);
-          struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0];
-          if (!deadp (s->u.s.car))
-            return make_lisp_ptr (s, Lisp_Cons);
-        }
+      cp = ptr_bounds_copy (cp, b);
+      struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0];
+      if (!deadp (s->u.s.car))
+        return s;
     }
-  return Qnil;
+  return NULL;
 }
 
 static bool
 live_cons_p (struct mem_node *m, void *p)
 {
-  return !NILP (live_cons_holding (m, p));
+  return live_cons_holding (m, p) == p;
 }
 
 
 /* If P is a pointer into a live Lisp symbol object on the heap,
-   return the object.  Otherwise, return nil.  M is a pointer to the
+   return the object's address.  Otherwise, return NULL.  M points to the
    mem_block for P.  */
 
-static Lisp_Object
+static struct Lisp_Symbol *
 live_symbol_holding (struct mem_node *m, void *p)
 {
-  if (m->type == MEM_TYPE_SYMBOL)
+  eassert (m->type == MEM_TYPE_SYMBOL);
+  struct symbol_block *b = m->start;
+  char *cp = p;
+  ptrdiff_t offset = cp - (char *) &b->symbols[0];
+
+  /* P must point into the Lisp_Symbol, not be
+     one of the unused cells in the current symbol block,
+     and not be on the free-list.  */
+  if (0 <= offset && offset < sizeof b->symbols
+      && (b != symbol_block
+          || offset / sizeof b->symbols[0] < symbol_block_index))
     {
-      struct symbol_block *b = m->start;
-      char *cp = p;
-      ptrdiff_t offset = cp - (char *) &b->symbols[0];
-
-      /* P must point into the Lisp_Symbol, not be
-         one of the unused cells in the current symbol block,
-         and not be on the free-list.  */
-      if (0 <= offset && offset < sizeof b->symbols
-          && (b != symbol_block
-              || offset / sizeof b->symbols[0] < symbol_block_index))
-        {
-          cp = ptr_bounds_copy (cp, b);
-          struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0];
-          if (!deadp (s->u.s.function))
-            return make_lisp_symbol (s);
-        }
+      cp = ptr_bounds_copy (cp, b);
+      struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0];
+      if (!deadp (s->u.s.function))
+        return s;
     }
-  return Qnil;
+  return NULL;
 }
 
 static bool
 live_symbol_p (struct mem_node *m, void *p)
 {
-  return !NILP (live_symbol_holding (m, p));
+  return live_symbol_holding (m, p) == p;
 }
 
 
@@ -4559,66 +4553,70 @@ live_symbol_p (struct mem_node *m, void *p)
 static bool
 live_float_p (struct mem_node *m, void *p)
 {
-  if (m->type == MEM_TYPE_FLOAT)
-    {
-      struct float_block *b = m->start;
-      char *cp = p;
-      ptrdiff_t offset = cp - (char *) &b->floats[0];
-
-      /* P must point to the start of a Lisp_Float and not be
-         one of the unused cells in the current float block.  */
-      return (0 <= offset && offset < sizeof b->floats
-              && offset % sizeof b->floats[0] == 0
-              && (b != float_block
-                  || offset / sizeof b->floats[0] < float_block_index));
-    }
-  else
-    return 0;
+  eassert (m->type == MEM_TYPE_FLOAT);
+  struct float_block *b = m->start;
+  char *cp = p;
+  ptrdiff_t offset = cp - (char *) &b->floats[0];
+
+  /* P must point to the start of a Lisp_Float and not be
+     one of the unused cells in the current float block.  */
+  return (0 <= offset && offset < sizeof b->floats
+          && offset % sizeof b->floats[0] == 0
+          && (b != float_block
+              || offset / sizeof b->floats[0] < float_block_index));
 }
 
-/* If P is a pointer to a live vector-like object, return the object.
+/* If P is a pointer to a live, large vector-like object, return the object.
    Otherwise, return nil.
    M is a pointer to the mem_block for P.  */
 
-static Lisp_Object
-live_vector_holding (struct mem_node *m, void *p)
+static struct Lisp_Vector *
+live_large_vector_holding (struct mem_node *m, void *p)
 {
+  eassert (m->type == MEM_TYPE_VECTORLIKE);
   struct Lisp_Vector *vp = p;
+  struct Lisp_Vector *vector = large_vector_vec (m->start);
+  struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector));
+  return vector <= vp && vp < next ? vector : NULL;
+}
 
-  if (m->type == MEM_TYPE_VECTOR_BLOCK)
-    {
-      /* This memory node corresponds to a vector block.  */
-      struct vector_block *block = m->start;
-      struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data;
-
-      /* P is in the block's allocation range.  Scan the block
-         up to P and see whether P points to the start of some
-         vector which is not on a free list.  FIXME: check whether
-         some allocation patterns (probably a lot of short vectors)
-         may cause a substantial overhead of this loop.  */
-      while (VECTOR_IN_BLOCK (vector, block) && vector <= vp)
-        {
-          struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector));
-          if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE))
-            return make_lisp_ptr (vector, Lisp_Vectorlike);
-          vector = next;
-        }
-    }
-  else if (m->type == MEM_TYPE_VECTORLIKE)
+static bool
+live_large_vector_p (struct mem_node *m, void *p)
+{
+  return live_large_vector_holding (m, p) == p;
+}
+
+/* If P is a pointer to a live, small vector-like object, return the object.
+   Otherwise, return NULL.
+   M is a pointer to the mem_block for P.  */
+
+static struct Lisp_Vector *
+live_small_vector_holding (struct mem_node *m, void *p)
+{
+  eassert (m->type == MEM_TYPE_VECTOR_BLOCK);
+  struct Lisp_Vector *vp = p;
+  struct vector_block *block = m->start;
+  struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data;
+
+  /* P is in the block's allocation range.  Scan the block
+     up to P and see whether P points to the start of some
+     vector which is not on a free list.  FIXME: check whether
+     some allocation patterns (probably a lot of short vectors)
+     may cause a substantial overhead of this loop.  */
+  while (VECTOR_IN_BLOCK (vector, block) && vector <= vp)
     {
-      /* This memory node corresponds to a large vector.  */
-      struct Lisp_Vector *vector = large_vector_vec (m->start);
       struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector));
-      if (vector <= vp && vp < next)
-        return make_lisp_ptr (vector, Lisp_Vectorlike);
+      if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE))
+        return vector;
+      vector = next;
     }
-  return Qnil;
+  return NULL;
 }
 
 static bool
-live_vector_p (struct mem_node *m, void *p)
+live_small_vector_p (struct mem_node *m, void *p)
 {
-  return !NILP (live_vector_holding (m, p));
+  return live_small_vector_holding (m, p) == p;
 }
 
 /* Mark OBJ if we can prove it's a Lisp_Object.  */
@@ -4630,10 +4628,24 @@ mark_maybe_object (Lisp_Object obj)
   VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj));
 #endif
 
-  if (FIXNUMP (obj))
-    return;
+  int type_tag = XTYPE (obj);
+  intptr_t offset;
+
+  switch (type_tag)
+    {
+    case_Lisp_Int: case Lisp_Type_Unused0:
+      return;
+
+    case Lisp_Symbol:
+      offset = (intptr_t) lispsym;
+      break;
 
-  void *po = XPNTR (obj);
+    default:
+      offset = 0;
+      break;
+    }
+
+  void *po = (char *) XLP (obj) + (offset - LISP_WORD_TAG (type_tag));
 
   /* If the pointer is in the dump image and the dump has a record
      of the object starting at the place where the pointer points, we
@@ -4645,7 +4657,7 @@ mark_maybe_object (Lisp_Object obj)
       /* Don't use pdumper_object_p_precise here! It doesn't check the
          tag bits. OBJ here might be complete garbage, so we need to
          verify both the pointer and the tag.  */
-      if (XTYPE (obj) == pdumper_find_object_type (po))
+      if (pdumper_find_object_type (po) == type_tag)
         mark_object (obj);
       return;
     }
@@ -4656,30 +4668,33 @@ mark_maybe_object (Lisp_Object obj)
     {
       bool mark_p = false;
 
-      switch (XTYPE (obj))
+      switch (type_tag)
         {
         case Lisp_String:
-          mark_p = EQ (obj, live_string_holding (m, po));
+          mark_p = m->type == MEM_TYPE_STRING && live_string_p (m, po);
           break;
 
         case Lisp_Cons:
-          mark_p = EQ (obj, live_cons_holding (m, po));
+          mark_p = m->type == MEM_TYPE_CONS && live_cons_p (m, po);
           break;
 
         case Lisp_Symbol:
-          mark_p = EQ (obj, live_symbol_holding (m, po));
+          mark_p = m->type == MEM_TYPE_SYMBOL && live_symbol_p (m, po);
           break;
 
         case Lisp_Float:
-          mark_p = live_float_p (m, po);
+          mark_p = m->type == MEM_TYPE_FLOAT && live_float_p (m, po);
           break;
 
         case Lisp_Vectorlike:
-          mark_p = (EQ (obj, live_vector_holding (m, po)));
+          mark_p = (m->type == MEM_TYPE_VECTOR_BLOCK
+                    ? live_small_vector_p (m, po)
+                    : (m->type == MEM_TYPE_VECTORLIKE
+                       && live_large_vector_p (m, po)));
           break;
 
         default:
-          break;
+          eassume (false);
         }
 
       if (mark_p)
@@ -4720,43 +4735,71 @@ mark_maybe_pointer (void *p)
   m = mem_find (p);
   if (m != MEM_NIL)
     {
-      Lisp_Object obj = Qnil;
+      Lisp_Object obj;
 
       switch (m->type)
         {
         case MEM_TYPE_NON_LISP:
         case MEM_TYPE_SPARE:
           /* Nothing to do; not a pointer to Lisp memory.  */
-          break;
+          return;
 
         case MEM_TYPE_CONS:
-          obj = live_cons_holding (m, p);
+          {
+            struct Lisp_Cons *h = live_cons_holding (m, p);
+            if (!h)
+              return;
+            obj = make_lisp_ptr (h, Lisp_Cons);
+          }
           break;
 
         case MEM_TYPE_STRING:
-          obj = live_string_holding (m, p);
+          {
+            struct Lisp_String *h = live_string_holding (m, p);
+            if (!h)
+              return;
+            obj = make_lisp_ptr (h, Lisp_String);
+          }
           break;
 
         case MEM_TYPE_SYMBOL:
-          obj = live_symbol_holding (m, p);
+          {
+            struct Lisp_Symbol *h = live_symbol_holding (m, p);
+            if (!h)
+              return;
+            obj = make_lisp_symbol (h);
+          }
           break;
 
         case MEM_TYPE_FLOAT:
-          if (live_float_p (m, p))
-            obj = make_lisp_ptr (p, Lisp_Float);
+          if (! live_float_p (m, p))
+            return;
+          obj = make_lisp_ptr (p, Lisp_Float);
           break;
 
         case MEM_TYPE_VECTORLIKE:
+          {
+            struct Lisp_Vector *h = live_large_vector_holding (m, p);
+            if (!h)
+              return;
+            obj = make_lisp_ptr (h, Lisp_Vectorlike);
+          }
+          break;
+
         case MEM_TYPE_VECTOR_BLOCK:
-          obj = live_vector_holding (m, p);
+          {
+            struct Lisp_Vector *h = live_small_vector_holding (m, p);
+            if (!h)
+              return;
+            obj = make_lisp_ptr (h, Lisp_Vectorlike);
+          }
           break;
 
         default:
           emacs_abort ();
         }
 
-      if (!NILP (obj))
-        mark_object (obj);
+      mark_object (obj);
     }
 }
 
@@ -5163,8 +5206,10 @@ valid_lisp_object_p (Lisp_Object obj)
       return live_float_p (m, p);
 
     case MEM_TYPE_VECTORLIKE:
+      return live_large_vector_p (m, p);
+
     case MEM_TYPE_VECTOR_BLOCK:
-      return live_vector_p (m, p);
+      return live_small_vector_p (m, p);
 
     default:
       break;
@@ -5686,7 +5731,7 @@ compact_font_cache_entry (Lisp_Object entry)
                   struct font *font = GC_XFONT_OBJECT (val);
 
                   if (!NILP (AREF (val, FONT_TYPE_INDEX))
-                      && vectorlike_marked_p(&font->header))
+                      && vectorlike_marked_p (&font->header))
                     break;
                 }
               if (CONSP (objlist))
@@ -6525,7 +6570,7 @@ mark_object (Lisp_Object arg)
      structure allocated from the heap.  */
 #define CHECK_ALLOCATED()                       \
   do {                                          \
-    if (pdumper_object_p(po))                   \
+    if (pdumper_object_p (po))                  \
       {                                         \
         if (!pdumper_object_p_precise (po))     \
           emacs_abort ();                       \
@@ -6538,19 +6583,19 @@ mark_object (Lisp_Object arg)
 
   /* Check that the object pointed to by PO is live, using predicate
      function LIVEP.  */
-#define CHECK_LIVE(LIVEP)                       \
+#define CHECK_LIVE(LIVEP, MEM_TYPE)             \
   do {                                          \
-    if (pdumper_object_p(po))                   \
+    if (pdumper_object_p (po))                  \
       break;                                    \
-    if (!LIVEP (m, po))                         \
+    if (! (m->type == MEM_TYPE && LIVEP (m, po))) \
       emacs_abort ();                           \
   } while (0)
 
   /* Check both of the above conditions, for non-symbols.  */
-#define CHECK_ALLOCATED_AND_LIVE(LIVEP)         \
+#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \
   do {                                          \
     CHECK_ALLOCATED ();                         \
-    CHECK_LIVE (LIVEP);                         \
+    CHECK_LIVE (LIVEP, MEM_TYPE);               \
   } while (false)
 
   /* Check both of the above conditions, for symbols.  */
@@ -6559,15 +6604,14 @@ mark_object (Lisp_Object arg)
     if (!c_symbol_p (ptr))                      \
       {                                         \
         CHECK_ALLOCATED ();                     \
-        CHECK_LIVE (live_symbol_p);             \
+        CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \
       }                                         \
   } while (false)
 
 #else /* not GC_CHECK_MARKED_OBJECTS */
 
-#define CHECK_LIVE(LIVEP)                       ((void) 0)
-#define CHECK_ALLOCATED_AND_LIVE(LIVEP)         ((void) 0)
-#define CHECK_ALLOCATED_AND_LIVE_SYMBOL()       ((void) 0)
+#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE)       ((void) 0)
+#define CHECK_ALLOCATED_AND_LIVE_SYMBOL()               ((void) 0)
 
 #endif /* not GC_CHECK_MARKED_OBJECTS */
 
@@ -6578,7 +6622,7 @@ mark_object (Lisp_Object arg)
         register struct Lisp_String *ptr = XSTRING (obj);
         if (string_marked_p (ptr))
           break;
-        CHECK_ALLOCATED_AND_LIVE (live_string_p);
+        CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING);
         set_string_marked (ptr);
         mark_interval_tree (ptr->u.s.intervals);
 #ifdef GC_CHECK_STRING_BYTES
@@ -6596,21 +6640,21 @@ mark_object (Lisp_Object arg)
         if (vector_marked_p (ptr))
           break;
 
+        enum pvec_type pvectype
+          = PSEUDOVECTOR_TYPE (ptr);
+
 #ifdef GC_CHECK_MARKED_OBJECTS
-        if (!pdumper_object_p(po))
+        if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po))
           {
             m = mem_find (po);
-            if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po))
+            if (m == MEM_NIL)
               emacs_abort ();
+            if (m->type == MEM_TYPE_VECTORLIKE)
+              CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE);
+            else
+              CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK);
           }
-#endif /* GC_CHECK_MARKED_OBJECTS */
-
-        enum pvec_type pvectype
-          = PSEUDOVECTOR_TYPE (ptr);
-
-        if (pvectype != PVEC_SUBR &&
-            !main_thread_p (po))
-          CHECK_LIVE (live_vector_p);
+#endif
 
         switch (pvectype)
           {
@@ -6649,7 +6693,7 @@ mark_object (Lisp_Object arg)
             /* bool vectors in a dump are permanently "marked", since
                they're in the old section and don't have mark bits.
                If we're looking at a dumped bool vector, we should
-               have aborted above when we called vector_marked_p(), so
+               have aborted above when we called vector_marked_p, so
                we should never get here.  */
             eassert (!pdumper_object_p (ptr));
             set_vector_marked (ptr);
@@ -6687,7 +6731,7 @@ mark_object (Lisp_Object arg)
         if (symbol_marked_p (ptr))
           break;
         CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
-        set_symbol_marked(ptr);
+        set_symbol_marked (ptr);
         /* Attempt to catch bogus objects.  */
         eassert (valid_lisp_object_p (ptr->u.s.function));
         mark_object (ptr->u.s.function);
@@ -6728,7 +6772,7 @@ mark_object (Lisp_Object arg)
         struct Lisp_Cons *ptr = XCONS (obj);
         if (cons_marked_p (ptr))
           break;
-        CHECK_ALLOCATED_AND_LIVE (live_cons_p);
+        CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS);
         set_cons_marked (ptr);
         /* If the cdr is nil, avoid recursion for the car.  */
         if (NILP (ptr->u.s.u.cdr))
@@ -6746,7 +6790,7 @@ mark_object (Lisp_Object arg)
       }
 
     case Lisp_Float:
-      CHECK_ALLOCATED_AND_LIVE (live_float_p);
+      CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT);
       /* Do not mark floats stored in a dump image: these floats are
          "cold" and do not have mark bits.  */
       if (pdumper_object_p (XFLOAT (obj)))