1 files changed, 193 insertions, 132 deletions

diff --git a/src/alloc.c b/src/alloc.c
index 6e57b2024bc..300f5e420d3 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -2961,25 +2961,23 @@ verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
 
 /* Common shortcut to advance vector pointer over a block data.  */
 
-#define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
+static struct Lisp_Vector *
+ADVANCE (struct Lisp_Vector *v, ptrdiff_t nbytes)
+{
+  void *vv = v;
+  char *cv = vv;
+  void *p = cv + nbytes;
+  return p;
+}
 
 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS.  */
 
-#define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
-
-/* Common shortcut to setup vector on a free list.  */
-
-#define SETUP_ON_FREE_LIST(v, nbytes, tmp)              \
-  do {                                                  \
-    (tmp) = ((nbytes - header_size) / word_size);       \
-    XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp));          \
-    eassert ((nbytes) % roundup_size == 0);             \
-    (tmp) = VINDEX (nbytes);                            \
-    eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX);       \
-    set_next_vector (v, vector_free_lists[tmp]);        \
-    vector_free_lists[tmp] = (v);                       \
-    total_free_vector_slots += (nbytes) / word_size;    \
-  } while (0)
+static ptrdiff_t
+VINDEX (ptrdiff_t nbytes)
+{
+  eassume (VBLOCK_BYTES_MIN <= nbytes);
+  return (nbytes - VBLOCK_BYTES_MIN) / roundup_size;
+}
 
 /* This internal type is used to maintain the list of large vectors
    which are allocated at their own, e.g. outside of vector blocks.
@@ -3041,6 +3039,22 @@ static EMACS_INT total_vectors;
 
 static EMACS_INT total_vector_slots, total_free_vector_slots;
 
+/* Common shortcut to setup vector on a free list.  */
+
+static void
+setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes)
+{
+  eassume (header_size <= nbytes);
+  ptrdiff_t nwords = (nbytes - header_size) / word_size;
+  XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords);
+  eassert (nbytes % roundup_size == 0);
+  ptrdiff_t vindex = VINDEX (nbytes);
+  eassert (vindex < VECTOR_MAX_FREE_LIST_INDEX);
+  set_next_vector (v, vector_free_lists[vindex]);
+  vector_free_lists[vindex] = v;
+  total_free_vector_slots += nbytes / word_size;
+}
+
 /* Get a new vector block.  */
 
 static struct vector_block *
@@ -3105,7 +3119,7 @@ allocate_vector_from_block (size_t nbytes)
            which should be set on an appropriate free list.  */
         restbytes = index * roundup_size + VBLOCK_BYTES_MIN - nbytes;
         eassert (restbytes % roundup_size == 0);
-        SETUP_ON_FREE_LIST (ADVANCE (vector, nbytes), restbytes, index);
+        setup_on_free_list (ADVANCE (vector, nbytes), restbytes);
         return vector;
       }
 
@@ -3121,7 +3135,7 @@ allocate_vector_from_block (size_t nbytes)
   if (restbytes >= VBLOCK_BYTES_MIN)
     {
       eassert (restbytes % roundup_size == 0);
-      SETUP_ON_FREE_LIST (ADVANCE (vector, nbytes), restbytes, index);
+      setup_on_free_list (ADVANCE (vector, nbytes), restbytes);
     }
   return vector;
 }
@@ -3253,10 +3267,7 @@ sweep_vectors (void)
                    space was coalesced into the only free vector.  */
                 free_this_block = 1;
               else
-                {
-                  size_t tmp;
-                  SETUP_ON_FREE_LIST (vector, total_bytes, tmp);
-                }
+                setup_on_free_list (vector, total_bytes);
             }
         }
 
@@ -4171,7 +4182,7 @@ refill_memory_reserve (void)
    block to the red-black tree with calls to mem_insert, and function
    lisp_free removes it with mem_delete.  Functions live_string_p etc
    call mem_find to lookup information about a given pointer in the
-   tree, and use that to determine if the pointer points to a Lisp
+   tree, and use that to determine if the pointer points into a Lisp
    object or not.  */
 
 /* Initialize this part of alloc.c.  */
@@ -4549,82 +4560,113 @@ mem_delete_fixup (struct mem_node *x)
 }
 
 
-/* Value is non-zero if P is a pointer to a live Lisp string on
-   the heap.  M is a pointer to the mem_block for P.  */
+/* 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
+   mem_block for P.
 
-static bool
-live_string_p (struct mem_node *m, void *p)
+   This and other *_holding functions look for a pointer anywhere into
+   the object, not merely for a pointer to the start of the object,
+   because some compilers sometimes optimize away the latter.  See
+   Bug#28213.  */
+
+static Lisp_Object
+live_string_holding (struct mem_node *m, void *p)
 {
   if (m->type == MEM_TYPE_STRING)
     {
       struct string_block *b = m->start;
-      ptrdiff_t offset = (char *) p - (char *) &b->strings[0];
+      char *cp = p;
+      ptrdiff_t offset = cp - (char *) &b->strings[0];
 
-      /* P must point to the start of a Lisp_String structure, and it
+      /* P must point into a Lisp_String structure, and it
          must not be on the free-list.  */
-      return (offset >= 0
-              && offset % sizeof b->strings[0] == 0
-              && offset < (STRING_BLOCK_SIZE * sizeof b->strings[0])
-              && ((struct Lisp_String *) p)->data != NULL);
+      if (0 <= offset && offset < STRING_BLOCK_SIZE * sizeof b->strings[0])
+        {
+          struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0];
+          if (s->data)
+            return make_lisp_ptr (s, Lisp_String);
+        }
     }
-  else
-    return 0;
+  return Qnil;
 }
 
+static bool
+live_string_p (struct mem_node *m, void *p)
+{
+  return !NILP (live_string_holding (m, p));
+}
 
-/* Value is non-zero if P is a pointer to a live Lisp cons on
-   the heap.  M is a pointer to the mem_block for 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
+   mem_block for P.  */
 
-static bool
-live_cons_p (struct mem_node *m, void *p)
+static Lisp_Object
+live_cons_holding (struct mem_node *m, void *p)
 {
   if (m->type == MEM_TYPE_CONS)
     {
       struct cons_block *b = m->start;
-      ptrdiff_t offset = (char *) p - (char *) &b->conses[0];
+      char *cp = p;
+      ptrdiff_t offset = cp - (char *) &b->conses[0];
 
-      /* P must point to the start of a Lisp_Cons, not be
+      /* 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.  */
-      return (offset >= 0
-              && offset % sizeof b->conses[0] == 0
-              && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
-              && (b != cons_block
-                  || offset / sizeof b->conses[0] < cons_block_index)
-              && !EQ (((struct Lisp_Cons *) p)->car, Vdead));
+      if (0 <= offset && offset < CONS_BLOCK_SIZE * sizeof b->conses[0]
+          && (b != cons_block
+              || offset / sizeof b->conses[0] < cons_block_index))
+        {
+          struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0];
+          if (!EQ (s->car, Vdead))
+            return make_lisp_ptr (s, Lisp_Cons);
+        }
     }
-  else
-    return 0;
+  return Qnil;
 }
 
+static bool
+live_cons_p (struct mem_node *m, void *p)
+{
+  return !NILP (live_cons_holding (m, p));
+}
 
-/* Value is non-zero if P is a pointer to a live Lisp symbol on
-   the heap.  M is a pointer to the mem_block for P.  */
 
-static bool
-live_symbol_p (struct mem_node *m, void *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
+   mem_block for P.  */
+
+static Lisp_Object
+live_symbol_holding (struct mem_node *m, void *p)
 {
   if (m->type == MEM_TYPE_SYMBOL)
     {
       struct symbol_block *b = m->start;
-      ptrdiff_t offset = (char *) p - (char *) &b->symbols[0];
+      char *cp = p;
+      ptrdiff_t offset = cp - (char *) &b->symbols[0];
 
-      /* P must point to the start of a Lisp_Symbol, not be
+      /* 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.  */
-      return (offset >= 0
-              && offset % sizeof b->symbols[0] == 0
-              && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
-              && (b != symbol_block
-                  || offset / sizeof b->symbols[0] < symbol_block_index)
-              && !EQ (((struct Lisp_Symbol *)p)->function, Vdead));
+      if (0 <= offset && offset < SYMBOL_BLOCK_SIZE * sizeof b->symbols[0]
+          && (b != symbol_block
+              || offset / sizeof b->symbols[0] < symbol_block_index))
+        {
+          struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0];
+          if (!EQ (s->function, Vdead))
+            return make_lisp_symbol (s);
+        }
     }
-  else
-    return 0;
+  return Qnil;
 }
 
+static bool
+live_symbol_p (struct mem_node *m, void *p)
+{
+  return !NILP (live_symbol_holding (m, p));
+}
 
-/* Value is non-zero if P is a pointer to a live Lisp float on
+
+/* Return true if P is a pointer to a live Lisp float on
    the heap.  M is a pointer to the mem_block for P.  */
 
 static bool
@@ -4633,7 +4675,8 @@ live_float_p (struct mem_node *m, void *p)
   if (m->type == MEM_TYPE_FLOAT)
     {
       struct float_block *b = m->start;
-      ptrdiff_t offset = (char *) p - (char *) &b->floats[0];
+      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.  */
@@ -4648,38 +4691,48 @@ live_float_p (struct mem_node *m, void *p)
 }
 
 
-/* Value is non-zero if P is a pointer to a live Lisp Misc on
-   the heap.  M is a pointer to the mem_block for P.  */
+/* If P is a pointer to a live Lisp Misc on the heap, return the object.
+   Otherwise, return nil.  M is a pointer to the mem_block for P.  */
 
-static bool
-live_misc_p (struct mem_node *m, void *p)
+static Lisp_Object
+live_misc_holding (struct mem_node *m, void *p)
 {
   if (m->type == MEM_TYPE_MISC)
     {
       struct marker_block *b = m->start;
-      ptrdiff_t offset = (char *) p - (char *) &b->markers[0];
+      char *cp = p;
+      ptrdiff_t offset = cp - (char *) &b->markers[0];
 
-      /* P must point to the start of a Lisp_Misc, not be
+      /* P must point into a Lisp_Misc, not be
          one of the unused cells in the current misc block,
          and not be on the free-list.  */
-      return (offset >= 0
-              && offset % sizeof b->markers[0] == 0
-              && offset < (MARKER_BLOCK_SIZE * sizeof b->markers[0])
-              && (b != marker_block
-                  || offset / sizeof b->markers[0] < marker_block_index)
-              && ((union Lisp_Misc *) p)->u_any.type != Lisp_Misc_Free);
+      if (0 <= offset && offset < MARKER_BLOCK_SIZE * sizeof b->markers[0]
+          && (b != marker_block
+              || offset / sizeof b->markers[0] < marker_block_index))
+        {
+          union Lisp_Misc *s = p = cp -= offset % sizeof b->markers[0];
+          if (s->u_any.type != Lisp_Misc_Free)
+            return make_lisp_ptr (s, Lisp_Misc);
+        }
     }
-  else
-    return 0;
+  return Qnil;
 }
 
+static bool
+live_misc_p (struct mem_node *m, void *p)
+{
+  return !NILP (live_misc_holding (m, p));
+}
 
-/* Value is non-zero if P is a pointer to a live vector-like object.
+/* If P is a pointer to a live vector-like object, return the object.
+   Otherwise, return nil.
    M is a pointer to the mem_block for P.  */
 
-static bool
-live_vector_p (struct mem_node *m, void *p)
+static Lisp_Object
+live_vector_holding (struct mem_node *m, void *p)
 {
+  struct Lisp_Vector *vp = p;
+
   if (m->type == MEM_TYPE_VECTOR_BLOCK)
     {
       /* This memory node corresponds to a vector block.  */
@@ -4691,33 +4744,59 @@ live_vector_p (struct mem_node *m, void *p)
          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 <= (struct Lisp_Vector *) p)
+      while (VECTOR_IN_BLOCK (vector, block) && vector <= vp)
         {
-          if (!PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE) && vector == p)
-            return true;
-          else
-            vector = ADVANCE (vector, vector_nbytes (vector));
+          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 && p == large_vector_vec (m->start))
-    /* This memory node corresponds to a large vector.  */
-    return 1;
-  return 0;
+  else if (m->type == MEM_TYPE_VECTORLIKE)
+    {
+      /* 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);
+    }
+  return Qnil;
 }
 
+static bool
+live_vector_p (struct mem_node *m, void *p)
+{
+  return !NILP (live_vector_holding (m, p));
+}
 
-/* Value is non-zero if P is a pointer to a live buffer.  M is a
-   pointer to the mem_block for P.  */
+/* If P is a pointer into a live buffer, return the buffer.
+   Otherwise, return nil.  M is a pointer to the mem_block for P.  */
+
+static Lisp_Object
+live_buffer_holding (struct mem_node *m, void *p)
+{
+  /* P must point into the block, and the buffer
+     must not have been killed.  */
+  if (m->type == MEM_TYPE_BUFFER)
+    {
+      struct buffer *b = m->start;
+      char *cb = m->start;
+      char *cp = p;
+      ptrdiff_t offset = cp - cb;
+      if (0 <= offset && offset < sizeof *b && !NILP (b->name_))
+        {
+          Lisp_Object obj;
+          XSETBUFFER (obj, b);
+          return obj;
+        }
+    }
+  return Qnil;
+}
 
 static bool
 live_buffer_p (struct mem_node *m, void *p)
 {
-  /* P must point to the start of the block, and the buffer
-     must not have been killed.  */
-  return (m->type == MEM_TYPE_BUFFER
-          && p == m->start
-          && !NILP (((struct buffer *) p)->name_));
+  return !NILP (live_buffer_holding (m, p));
 }
 
 /* Mark OBJ if we can prove it's a Lisp_Object.  */
@@ -4743,34 +4822,28 @@ mark_maybe_object (Lisp_Object obj)
       switch (XTYPE (obj))
         {
         case Lisp_String:
-          mark_p = (live_string_p (m, po)
-                    && !STRING_MARKED_P ((struct Lisp_String *) po));
+          mark_p = EQ (obj, live_string_holding (m, po));
           break;
 
         case Lisp_Cons:
-          mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj)));
+          mark_p = EQ (obj, live_cons_holding (m, po));
           break;
 
         case Lisp_Symbol:
-          mark_p = (live_symbol_p (m, po) && !XSYMBOL (obj)->gcmarkbit);
+          mark_p = EQ (obj, live_symbol_holding (m, po));
           break;
 
         case Lisp_Float:
-          mark_p = (live_float_p (m, po) && !FLOAT_MARKED_P (XFLOAT (obj)));
+          mark_p = live_float_p (m, po);
           break;
 
         case Lisp_Vectorlike:
-          /* Note: can't check BUFFERP before we know it's a
-             buffer because checking that dereferences the pointer
-             PO which might point anywhere.  */
-          if (live_vector_p (m, po))
-            mark_p = !SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj));
-          else if (live_buffer_p (m, po))
-            mark_p = BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj));
+          mark_p = (EQ (obj, live_vector_holding (m, po))
+                    || EQ (obj, live_buffer_holding (m, po)));
           break;
 
         case Lisp_Misc:
-          mark_p = (live_misc_p (m, po) && !XMISCANY (obj)->gcmarkbit);
+          mark_p = EQ (obj, live_misc_holding (m, po));
           break;
 
         default:
@@ -4834,45 +4907,33 @@ mark_maybe_pointer (void *p)
           break;
 
         case MEM_TYPE_BUFFER:
-          if (live_buffer_p (m, p) && !VECTOR_MARKED_P ((struct buffer *)p))
-            XSETVECTOR (obj, p);
+          obj = live_buffer_holding (m, p);
           break;
 
         case MEM_TYPE_CONS:
-          if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p))
-            XSETCONS (obj, p);
+          obj = live_cons_holding (m, p);
           break;
 
         case MEM_TYPE_STRING:
-          if (live_string_p (m, p)
-              && !STRING_MARKED_P ((struct Lisp_String *) p))
-            XSETSTRING (obj, p);
+          obj = live_string_holding (m, p);
           break;
 
         case MEM_TYPE_MISC:
-          if (live_misc_p (m, p) && !((struct Lisp_Free *) p)->gcmarkbit)
-            XSETMISC (obj, p);
+          obj = live_misc_holding (m, p);
           break;
 
         case MEM_TYPE_SYMBOL:
-          if (live_symbol_p (m, p) && !((struct Lisp_Symbol *) p)->gcmarkbit)
-            XSETSYMBOL (obj, p);
+          obj = live_symbol_holding (m, p);
           break;
 
         case MEM_TYPE_FLOAT:
-          if (live_float_p (m, p) && !FLOAT_MARKED_P (p))
-            XSETFLOAT (obj, p);
+          if (live_float_p (m, p))
+            obj = make_lisp_ptr (p, Lisp_Float);
           break;
 
         case MEM_TYPE_VECTORLIKE:
         case MEM_TYPE_VECTOR_BLOCK:
-          if (live_vector_p (m, p))
-            {
-              Lisp_Object tem;
-              XSETVECTOR (tem, p);
-              if (!SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem)))
-                obj = tem;
-            }
+          obj = live_vector_holding (m, p);
           break;
 
         default: