Support concurrency in Emacs Lisp

Merge branch 'test-concurrency'

* src/thread.c:
* src/thread.h:
* src/systhread.c:
* src/systhread.h: New files.
* src/xgselect.c (xg_select): Avoid using SAFE_NALLOCA and use
xnmalloc unconditionally.
* src/window.c (struct save_window_data): Rename current_buffer to
f_current_buffer.
* src/w32proc.c (sys_select): Change the function signature to
closer fit 'pselect' on Posix hosts.
* src/search.c:
* src/regex.h: Convert some globals to macros that reference
thread-specific values.
* src/process.c (pset_thread, add_non_keyboard_read_fd)
(add_process_read_fd, add_non_blocking_write_fd)
(recompute_input_desc, compute_input_wait_mask)
(compute_non_process_wait_mask, compute_non_keyboard_wait_mask)
(compute_write_mask, clear_waiting_thread_info)
(update_processes_for_thread_death, Fset_process_thread)
(Fprocess_thread): New functions.
(enum fd_bits): New enumeration.
(fd_callback_data): Add 'thread' and 'waiting_thread', rename
'condition' to 'flags'.
(set_process_filter_masks, create_process, create_pty)
(Fmake_serial_process, finish_after_tls_connection)
(connect_network_socket, deactivate_process)
(server_accept_connection, wait_reading_process_output)
(Fcontinue_process, Fstop_process, keyboard_bit_set)
(add_timer_wait_descriptor, add_keyboard_wait_descriptor)
(delete_keyboard_wait_descriptor): Use the new functions instead
of manipulating fd flags and masks directly.
(syms_of_process): Defsubr the new primitives.
* src/print.c (print_object): Print threads, mutexes, and
conditional variables.
* src/lisp.h (enum pvec_type): New values PVEC_THREAD, PVEC_MUTEX,
and PVEC_CONDVAR.
(XTHREAD, XMUTEX, XCONDVAR, THREADP, MUTEXP, CONDVARP)
(CHECK_THREAD, CHECK_MUTEX, CHECK_CONDVAR): New inline functions.
(XSETTHREAD, XSETMUTEX, XSETCONDVAR): New macros.
(struct handler): Add back byte_stack.  Rename lisp_eval_depth to
f_lisp_eval_depth.
* src/eval.c (specpdl_kind, specpdl_arg, do_specbind)
(rebind_for_thread_switch, do_one_unbind)
(unbind_for_thread_switch): New functions.
(init_eval): 'handlerlist' is not malloc'ed.
(specbind): Call do_specbind.
(unbind_to): Call do_one_unbind.
(mark_specpdl): Accept 2 arguments.
(mark_specpdl): Mark the saved value in a let-binding.
* src/emacs.c (main): Call init_threads_once, init_threads, and
syms_of_threads.
* src/data.c (Ftype_of): Support thread, mutex, and condvar
objects.
(Fthreadp, Fmutexp, Fcondition_variable_p): New functions.
(syms_of_data): DEFSYM and defsubr new symbols and primitives.
* src/bytecode.c (struct byte_stack, FETCH, CHECK_RANGE)
(BYTE_CODE_QUIT): Add back.
(exec_byte_code): Add back byte stack manipulation.
* src/alloc.c (cleanup_vector): Handle threads, mutexes, and
conditional variables.
(mark_stack): Now extern; accept additional argument 'bottom'.
(flush_stack_call_func): New function.
(garbage_collect_1): Call mark_threads and unmark_threads.  Don't
mark handlers.
* src/.gdbinit (xbytecode): Add back.

* test/src/thread-tests.el: New tests.
* test/src/data-tests.el (binding-test-manual)
(binding-test-setq-default, binding-test-makunbound)
(binding-test-defvar-bool, binding-test-defvar-int)
(binding-test-set-constant-t, binding-test-set-constant-nil)
(binding-test-set-constant-keyword)
(binding-test-set-constant-nil): New tests.

* doc/lispref/processes.texi (Processes and Threads): New
subsection.
* doc/lispref/threads.texi: New file
* doc/lispref/elisp.texi (Top): Include it.
* doc/lispref/objects.texi (Thread Type, Mutex Type)
(Condition Variable Type): New subsections.
(Type Predicates): Add thread-related predicates.
* doc/lispref/objects.texi (Editing Types):
* doc/lispref/elisp.texi (Top): Update higher-level menus.

* etc/NEWS: Mention concurrency features.

1 files changed, 89 insertions, 21 deletions

diff --git a/src/alloc.c b/src/alloc.c
index 6eced7bab18..f2b7682b05d 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -438,10 +438,6 @@ struct mem_node
   enum mem_type type;
 };
 
-/* Base address of stack.  Set in main.  */
-
-Lisp_Object *stack_base;
-
 /* Root of the tree describing allocated Lisp memory.  */
 
 static struct mem_node *mem_root;
@@ -3190,8 +3186,7 @@ vector_nbytes (struct Lisp_Vector *v)
 }
 
 /* Release extra resources still in use by VECTOR, which may be any
-   vector-like object.  For now, this is used just to free data in
-   font objects.  */
+   vector-like object.  */
 
 static void
 cleanup_vector (struct Lisp_Vector *vector)
@@ -3212,6 +3207,13 @@ cleanup_vector (struct Lisp_Vector *vector)
 	  drv->close ((struct font *) vector);
 	}
     }
+
+  if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
+    finalize_one_thread ((struct thread_state *) vector);
+  else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
+    finalize_one_mutex ((struct Lisp_Mutex *) vector);
+  else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
+    finalize_one_condvar ((struct Lisp_CondVar *) vector);
 }
 
 /* Reclaim space used by unmarked vectors.  */
@@ -5047,14 +5049,13 @@ test_setjmp (void)
    would be necessary, each one starting with one byte more offset
    from the stack start.  */
 
-static void
-mark_stack (void *end)
+void
+mark_stack (char *bottom, char *end)
 {
-
   /* This assumes that the stack is a contiguous region in memory.  If
      that's not the case, something has to be done here to iterate
      over the stack segments.  */
-  mark_memory (stack_base, end);
+  mark_memory (bottom, end);
 
   /* Allow for marking a secondary stack, like the register stack on the
      ia64.  */
@@ -5063,6 +5064,81 @@ mark_stack (void *end)
 #endif
 }
 
+/* This is a trampoline function that flushes registers to the stack,
+   and then calls FUNC.  ARG is passed through to FUNC verbatim.
+
+   This function must be called whenever Emacs is about to release the
+   global interpreter lock.  This lets the garbage collector easily
+   find roots in registers on threads that are not actively running
+   Lisp.
+
+   It is invalid to run any Lisp code or to allocate any GC memory
+   from FUNC.  */
+
+void
+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 */
+
+  self->stack_top = end;
+  (*func) (arg);
+
+  eassert (current_thread == self);
+}
+
 static bool
 c_symbol_p (struct Lisp_Symbol *sym)
 {
@@ -5768,24 +5844,14 @@ garbage_collect_1 (void *end)
     mark_object (*staticvec[i]);
 
   mark_pinned_symbols ();
-  mark_specpdl ();
   mark_terminals ();
   mark_kboards ();
+  mark_threads ();
 
 #ifdef USE_GTK
   xg_mark_data ();
 #endif
 
-  mark_stack (end);
-
-  {
-    struct handler *handler;
-    for (handler = handlerlist; handler; handler = handler->next)
-      {
-	mark_object (handler->tag_or_ch);
-	mark_object (handler->val);
-      }
-  }
 #ifdef HAVE_WINDOW_SYSTEM
   mark_fringe_data ();
 #endif
@@ -5817,6 +5883,8 @@ garbage_collect_1 (void *end)
 
   gc_sweep ();
 
+  unmark_threads ();
+
   /* Clear the mark bits that we set in certain root slots.  */
   VECTOR_UNMARK (&buffer_defaults);
   VECTOR_UNMARK (&buffer_local_symbols);