1 files changed, 142 insertions, 157 deletions

diff --git a/src/alloc.c b/src/alloc.c
index 1a6d4e2d565..62f43669f2a 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -2872,45 +2872,15 @@ usage: (list &rest OBJECTS)  */)
 
 DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
        doc: /* Return a newly created list of length LENGTH, with each element being INIT.  */)
-  (register Lisp_Object length, Lisp_Object init)
+  (Lisp_Object length, Lisp_Object init)
 {
-  register Lisp_Object val;
-  register EMACS_INT size;
-
+  Lisp_Object val = Qnil;
   CHECK_NATNUM (length);
-  size = XFASTINT (length);
 
-  val = Qnil;
-  while (size > 0)
+  for (EMACS_INT size = XFASTINT (length); 0 < size; size--)
     {
       val = Fcons (init, val);
-      --size;
-
-      if (size > 0)
-        {
-          val = Fcons (init, val);
-          --size;
-
-          if (size > 0)
-            {
-              val = Fcons (init, val);
-              --size;
-
-              if (size > 0)
-                {
-                  val = Fcons (init, val);
-                  --size;
-
-                  if (size > 0)
-                    {
-                      val = Fcons (init, val);
-                      --size;
-                    }
-                }
-            }
-        }
-
-      QUIT;
+      rarely_quit (size);
     }
 
   return val;
@@ -4917,12 +4887,19 @@ mark_memory (void *start, void *end)
     }
 }
 
-#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
+#ifndef HAVE___BUILTIN_UNWIND_INIT
+
+# ifdef GC_SETJMP_WORKS
+static void
+test_setjmp (void)
+{
+}
+# else
 
 static bool setjmp_tested_p;
 static int longjmps_done;
 
-#define SETJMP_WILL_LIKELY_WORK "\
+#  define SETJMP_WILL_LIKELY_WORK "\
 \n\
 Emacs garbage collector has been changed to use conservative stack\n\
 marking.  Emacs has determined that the method it uses to do the\n\
@@ -4935,7 +4912,7 @@ verify that the methods used are appropriate for your system.\n\
 Please mail the result to <emacs-devel@gnu.org>.\n\
 "
 
-#define SETJMP_WILL_NOT_WORK "\
+#  define SETJMP_WILL_NOT_WORK "\
 \n\
 Emacs garbage collector has been changed to use conservative stack\n\
 marking.  Emacs has determined that the default method it uses to do the\n\
@@ -4961,6 +4938,9 @@ Please mail the result to <emacs-devel@gnu.org>.\n\
 static void
 test_setjmp (void)
 {
+  if (setjmp_tested_p)
+    return;
+  setjmp_tested_p = true;
   char buf[10];
   register int x;
   sys_jmp_buf jbuf;
@@ -4997,9 +4977,60 @@ test_setjmp (void)
   if (longjmps_done == 1)
     sys_longjmp (jbuf, 1);
 }
+# endif /* ! GC_SETJMP_WORKS */
+#endif /* ! HAVE___BUILTIN_UNWIND_INIT */
 
-#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
+/* The type of an object near the stack top, whose address can be used
+   as a stack scan limit.  */
+typedef union
+{
+  /* Align the stack top properly.  Even if !HAVE___BUILTIN_UNWIND_INIT,
+     jmp_buf may not be aligned enough on darwin-ppc64.  */
+  max_align_t o;
+#ifndef HAVE___BUILTIN_UNWIND_INIT
+  sys_jmp_buf j;
+  char c;
+#endif
+} stacktop_sentry;
+
+/* Force callee-saved registers and register windows onto the stack.
+   Use the platform-defined __builtin_unwind_init if available,
+   obviating the need for machine dependent methods.  */
+#ifndef HAVE___BUILTIN_UNWIND_INIT
+# ifdef __sparc__
+   /* This trick flushes the register windows so that all the state of
+      the process is contained in the stack.
+      FreeBSD does not have a ta 3 handler, so handle it specially.
+      FIXME: Code in the Boehm GC suggests flushing (with 'flushrs') is
+      needed on ia64 too.  See mach_dep.c, where it also says inline
+      assembler doesn't work with relevant proprietary compilers.  */
+#  if defined __sparc64__ && defined __FreeBSD__
+#   define __builtin_unwind_init() asm ("flushw")
+#  else
+#   define __builtin_unwind_init() asm ("ta 3")
+#  endif
+# else
+#  define __builtin_unwind_init() ((void) 0)
+# endif
+#endif
 
+/* Set *P to the address of the top of the stack.  This must be a
+   macro, not a function, so that it is executed in the caller’s
+   environment.  It is not inside a do-while so that its storage
+   survives the macro.  */
+#ifdef HAVE___BUILTIN_UNWIND_INIT
+# define SET_STACK_TOP_ADDRESS(p)       \
+   stacktop_sentry sentry;              \
+   __builtin_unwind_init ();            \
+   *(p) = &sentry
+#else
+# define SET_STACK_TOP_ADDRESS(p)               \
+   stacktop_sentry sentry;                      \
+   __builtin_unwind_init ();                    \
+   test_setjmp ();                              \
+   sys_setjmp (sentry.j);                       \
+   *(p) = &sentry + (stack_bottom < &sentry.c)
+#endif
 
 /* Mark live Lisp objects on the C stack.
 
@@ -5011,12 +5042,7 @@ test_setjmp (void)
    We have to mark Lisp objects in CPU registers that can hold local
    variables or are used to pass parameters.
 
-   If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
-   something that either saves relevant registers on the stack, or
-   calls mark_maybe_object passing it each register's contents.
-
-   If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
-   implementation assumes that calling setjmp saves registers we need
+   This code assumes that calling setjmp saves registers we need
    to see in a jmp_buf which itself lies on the stack.  This doesn't
    have to be true!  It must be verified for each system, possibly
    by taking a look at the source code of setjmp.
@@ -5080,62 +5106,9 @@ flush_stack_call_func (void (*func) (void *arg), void *arg)
 {
   void *end;
   struct thread_state *self = current_thread;
-
-#ifdef HAVE___BUILTIN_UNWIND_INIT
-  /* Force callee-saved registers and register windows onto the stack.
-     This is the preferred method if available, obviating the need for
-     machine dependent methods.  */
-  __builtin_unwind_init ();
-  end = &end;
-#else /* not HAVE___BUILTIN_UNWIND_INIT */
-#ifndef GC_SAVE_REGISTERS_ON_STACK
-  /* jmp_buf may not be aligned enough on darwin-ppc64 */
-  union aligned_jmpbuf {
-    Lisp_Object o;
-    sys_jmp_buf j;
-  } j;
-  volatile bool stack_grows_down_p = (char *) &j > (char *) stack_bottom;
-#endif
-  /* This trick flushes the register windows so that all the state of
-     the process is contained in the stack.  */
-  /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
-     needed on ia64 too.  See mach_dep.c, where it also says inline
-     assembler doesn't work with relevant proprietary compilers.  */
-#ifdef __sparc__
-#if defined (__sparc64__) && defined (__FreeBSD__)
-  /* FreeBSD does not have a ta 3 handler.  */
-  asm ("flushw");
-#else
-  asm ("ta 3");
-#endif
-#endif
-
-  /* Save registers that we need to see on the stack.  We need to see
-     registers used to hold register variables and registers used to
-     pass parameters.  */
-#ifdef GC_SAVE_REGISTERS_ON_STACK
-  GC_SAVE_REGISTERS_ON_STACK (end);
-#else /* not GC_SAVE_REGISTERS_ON_STACK */
-
-#ifndef GC_SETJMP_WORKS  /* If it hasn't been checked yet that
-                            setjmp will definitely work, test it
-                            and print a message with the result
-                            of the test.  */
-  if (!setjmp_tested_p)
-    {
-      setjmp_tested_p = 1;
-      test_setjmp ();
-    }
-#endif /* GC_SETJMP_WORKS */
-
-  sys_setjmp (j.j);
-  end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
-#endif /* not GC_SAVE_REGISTERS_ON_STACK */
-#endif /* not HAVE___BUILTIN_UNWIND_INIT */
-
+  SET_STACK_TOP_ADDRESS (&end);
   self->stack_top = end;
-  (*func) (arg);
-
+  func (arg);
   eassert (current_thread == self);
 }
 
@@ -5464,6 +5437,38 @@ make_pure_vector (ptrdiff_t len)
   return new;
 }
 
+/* Copy all contents and parameters of TABLE to a new table allocated
+   from pure space, return the purified table.  */
+static struct Lisp_Hash_Table *
+purecopy_hash_table (struct Lisp_Hash_Table *table)
+{
+  eassert (NILP (table->weak));
+  eassert (!NILP (table->pure));
+
+  struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike);
+  struct hash_table_test pure_test = table->test;
+
+  /* Purecopy the hash table test.  */
+  pure_test.name = purecopy (table->test.name);
+  pure_test.user_hash_function = purecopy (table->test.user_hash_function);
+  pure_test.user_cmp_function = purecopy (table->test.user_cmp_function);
+
+  pure->test = pure_test;
+  pure->header = table->header;
+  pure->weak = purecopy (Qnil);
+  pure->rehash_size = purecopy (table->rehash_size);
+  pure->rehash_threshold = purecopy (table->rehash_threshold);
+  pure->hash = purecopy (table->hash);
+  pure->next = purecopy (table->next);
+  pure->next_free = purecopy (table->next_free);
+  pure->index = purecopy (table->index);
+  pure->count = table->count;
+  pure->key_and_value = purecopy (table->key_and_value);
+  pure->pure = purecopy (table->pure);
+
+  return pure;
+}
+
 DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
        doc: /* Make a copy of object OBJ in pure storage.
 Recursively copies contents of vectors and cons cells.
@@ -5472,14 +5477,20 @@ Does not copy symbols.  Copies strings without text properties.  */)
 {
   if (NILP (Vpurify_flag))
     return obj;
-  else if (MARKERP (obj) || OVERLAYP (obj)
-           || HASH_TABLE_P (obj) || SYMBOLP (obj))
+  else if (MARKERP (obj) || OVERLAYP (obj) || SYMBOLP (obj))
     /* Can't purify those.  */
     return obj;
   else
     return purecopy (obj);
 }
 
+/* Pinned objects are marked before every GC cycle.  */
+static struct pinned_object
+{
+  Lisp_Object object;
+  struct pinned_object *next;
+} *pinned_objects;
+
 static Lisp_Object
 purecopy (Lisp_Object obj)
 {
@@ -5507,7 +5518,27 @@ purecopy (Lisp_Object obj)
     obj = make_pure_string (SSDATA (obj), SCHARS (obj),
                             SBYTES (obj),
                             STRING_MULTIBYTE (obj));
-  else if (COMPILEDP (obj) || VECTORP (obj) || HASH_TABLE_P (obj))
+  else if (HASH_TABLE_P (obj))
+    {
+      struct Lisp_Hash_Table *table = XHASH_TABLE (obj);
+      /* Do not purify hash tables which haven't been defined with
+         :purecopy as non-nil or are weak - they aren't guaranteed to
+         not change.  */
+      if (!NILP (table->weak) || NILP (table->pure))
+        {
+          /* Instead, add the hash table to the list of pinned objects,
+             so that it will be marked during GC.  */
+          struct pinned_object *o = xmalloc (sizeof *o);
+          o->object = obj;
+          o->next = pinned_objects;
+          pinned_objects = o;
+          return obj; /* Don't hash cons it.  */
+        }
+
+      struct Lisp_Hash_Table *h = purecopy_hash_table (table);
+      XSET_HASH_TABLE (obj, h);
+    }
+  else if (COMPILEDP (obj) || VECTORP (obj))
     {
       struct Lisp_Vector *objp = XVECTOR (obj);
       ptrdiff_t nbytes = vector_nbytes (objp);
@@ -5724,6 +5755,13 @@ compact_undo_list (Lisp_Object list)
 }
 
 static void
+mark_pinned_objects (void)
+{
+  for (struct pinned_object *pobj = pinned_objects; pobj; pobj = pobj->next)
+    mark_object (pobj->object);
+}
+
+static void
 mark_pinned_symbols (void)
 {
   struct symbol_block *sblk;
@@ -5843,6 +5881,7 @@ garbage_collect_1 (void *end)
   for (i = 0; i < staticidx; i++)
     mark_object (*staticvec[i]);
 
+  mark_pinned_objects ();
   mark_pinned_symbols ();
   mark_terminals ();
   mark_kboards ();
@@ -6011,58 +6050,7 @@ See Info node `(elisp)Garbage Collection'.  */)
   (void)
 {
   void *end;
-
-#ifdef HAVE___BUILTIN_UNWIND_INIT
-  /* Force callee-saved registers and register windows onto the stack.
-     This is the preferred method if available, obviating the need for
-     machine dependent methods.  */
-  __builtin_unwind_init ();
-  end = &end;
-#else /* not HAVE___BUILTIN_UNWIND_INIT */
-#ifndef GC_SAVE_REGISTERS_ON_STACK
-  /* jmp_buf may not be aligned enough on darwin-ppc64 */
-  union aligned_jmpbuf {
-    Lisp_Object o;
-    sys_jmp_buf j;
-  } j;
-  volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base;
-#endif
-  /* This trick flushes the register windows so that all the state of
-     the process is contained in the stack.  */
-  /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
-     needed on ia64 too.  See mach_dep.c, where it also says inline
-     assembler doesn't work with relevant proprietary compilers.  */
-#ifdef __sparc__
-#if defined (__sparc64__) && defined (__FreeBSD__)
-  /* FreeBSD does not have a ta 3 handler.  */
-  asm ("flushw");
-#else
-  asm ("ta 3");
-#endif
-#endif
-
-  /* Save registers that we need to see on the stack.  We need to see
-     registers used to hold register variables and registers used to
-     pass parameters.  */
-#ifdef GC_SAVE_REGISTERS_ON_STACK
-  GC_SAVE_REGISTERS_ON_STACK (end);
-#else /* not GC_SAVE_REGISTERS_ON_STACK */
-
-#ifndef GC_SETJMP_WORKS  /* If it hasn't been checked yet that
-                            setjmp will definitely work, test it
-                            and print a message with the result
-                            of the test.  */
-  if (!setjmp_tested_p)
-    {
-      setjmp_tested_p = 1;
-      test_setjmp ();
-    }
-#endif /* GC_SETJMP_WORKS */
-
-  sys_setjmp (j.j);
-  end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
-#endif /* not GC_SAVE_REGISTERS_ON_STACK */
-#endif /* not HAVE___BUILTIN_UNWIND_INIT */
+  SET_STACK_TOP_ADDRESS (&end);
   return garbage_collect_1 (end);
 }
 
@@ -7372,9 +7360,6 @@ init_alloc_once (void)
 void
 init_alloc (void)
 {
-#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
-  setjmp_tested_p = longjmps_done = 0;
-#endif
   Vgc_elapsed = make_float (0.0);
   gcs_done = 0;