OPTION_DEFAULT_ON([selinux],[don't compile with SELinux support])
OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support])
OPTION_DEFAULT_ON([zlib],[don't compile with zlib decompression support])
+OPTION_DEFAULT_OFF([modules],[compile with dynamic modules support])
+ OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support])
AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB],
- [use a file notification library (LIB one of: yes, gfile, inotify, w32, no)])],
+ [use a file notification library (LIB one of: yes, inotify, kqueue, gfile, w32, no)])],
[ case "${withval}" in
y | ye | yes ) val=yes ;;
n | no ) val=no ;;
sys/sysinfo.h
coff.h pty.h
sys/resource.h
- sys/utsname.h pwd.h utmp.h util.h)
+ sys/utsname.h pwd.h utmp.h util.h sys/prctl.h)
-AC_MSG_CHECKING(if personality LINUX32 can be set)
-AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/personality.h>]], [[personality (PER_LINUX32)]])],
- emacs_cv_personality_linux32=yes,
- emacs_cv_personality_linux32=no)
-AC_MSG_RESULT($emacs_cv_personality_linux32)
-
-if test $emacs_cv_personality_linux32 = yes; then
- AC_DEFINE(HAVE_PERSONALITY_LINUX32, 1,
- [Define to 1 if personality LINUX32 can be set.])
+AC_CACHE_CHECK([for ADDR_NO_RANDOMIZE],
+ [emacs_cv_personality_addr_no_randomize],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[#include <sys/personality.h>]],
+ [[personality (personality (0xffffffff)
+ | ADDR_NO_RANDOMIZE)]])],
+ [emacs_cv_personality_addr_no_randomize=yes],
+ [emacs_cv_personality_addr_no_randomize=no])])
+if test $emacs_cv_personality_addr_no_randomize = yes; then
+ AC_DEFINE([HAVE_PERSONALITY_ADDR_NO_RANDOMIZE], [1],
+ [Define to 1 if personality flag ADDR_NO_RANDOMIZE exists.])
fi
# Note that Solaris has sys/sysinfo.h which defines struct
getrusage get_current_dir_name \
lrand48 random rint \
select getpagesize setlocale newlocale \
-getrlimit setrlimit shutdown getaddrinfo \
+getrlimit setrlimit shutdown \
pthread_sigmask strsignal setitimer \
-sendto recvfrom getsockname getpeername getifaddrs freeifaddrs \
+sendto recvfrom getsockname getifaddrs freeifaddrs \
gai_strerror sync \
getpwent endpwent getgrent endgrent \
- cfmakeraw cfsetspeed copysign __executable_start log2)
+ cfmakeraw cfsetspeed copysign __executable_start log2 prctl)
LIBS=$OLD_LIBS
-dnl No need to check for aligned_alloc and posix_memalign if using
-dnl gmalloc.o, as it supplies them, unless we're using hybrid_malloc.
-dnl Don't use these functions on Darwin as they are incompatible with
-dnl unexmacosx.c.
-if (test -z "$GMALLOC_OBJ" || test "$hybrid_malloc" = yes) \
- && test "$opsys" != darwin; then
- AC_CHECK_FUNCS([aligned_alloc posix_memalign], [break])
-fi
+dnl No need to check for posix_memalign if aligned_alloc works.
+AC_CHECK_FUNCS([aligned_alloc posix_memalign], [break])
+AC_CHECK_DECLS([aligned_alloc], [], [], [[#include <stdlib.h>]])
dnl Cannot use AC_CHECK_FUNCS
AC_CACHE_CHECK([for __builtin_unwind_init],
Does Emacs use -lm17n-flt? ${HAVE_M17N_FLT}
Does Emacs use -lotf? ${HAVE_LIBOTF}
Does Emacs use -lxft? ${HAVE_XFT}
+ Does Emacs use -lsystemd? ${HAVE_LIBSYSTEMD}
Does Emacs directly use zlib? ${HAVE_ZLIB}
+ Does Emacs have dynamic modules support? ${HAVE_MODULES}
Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS}
- Does Emacs have threading support in elisp? ${threads_enabled}
+ Does Emacs support Xwidgets (requires gtk3)? ${HAVE_XWIDGETS}
++ Does Emacs have threading support in lisp? ${threads_enabled}
"])
if test -n "${EMACSDATA}"; then
(match-string 1 subdir) subdir))
"-pkg.el"))
+ \f
+ ;;; Thread support.
+
+ (defmacro with-mutex (mutex &rest body)
+ "Invoke BODY with MUTEX held, releasing MUTEX when done.
+ This is the simplest safe way to acquire and release a mutex."
+ (declare (indent 1) (debug t))
+ (let ((sym (make-symbol "mutex")))
+ `(let ((,sym ,mutex))
+ (mutex-lock ,sym)
+ (unwind-protect
+ (progn ,@body)
+ (mutex-unlock ,sym)))))
+
\f
;;; Misc.
+
+(defvar definition-prefixes (make-hash-table :test 'equal)
+ "Hash table mapping prefixes to the files in which they're used.
+This can be used to automatically fetch not-yet-loaded definitions.
+More specifically, if there is a value of the form (FILES...) for a string PREFIX
+it means that the FILES define variables or functions with names that start
+with PREFIX.
+
+Note that it does not imply that all definitions starting with PREFIX can
+be found in those files. E.g. if prefix is \"gnus-article-\" there might
+still be definitions of the form \"gnus-article-toto-titi\" in other files, which would
+presumably appear in this table under another prefix such as \"gnus-\"
+or \"gnus-article-toto-\".")
+
+(defun register-definition-prefixes (file prefixes)
+ "Register that FILE uses PREFIXES."
+ (dolist (prefix prefixes)
+ (puthash prefix (cons file (gethash prefix definition-prefixes))
+ definition-prefixes)))
+
(defconst menu-bar-separator '("--")
"Separator for menus.")
process.o gnutls.o callproc.o \
region-cache.o sound.o atimer.o \
doprnt.o intervals.o textprop.o composite.o xml.o $(NOTIFY_OBJ) \
+ $(XWIDGETS_OBJ) \
profiler.o decompress.o \
+ thread.o systhread.o \
+ $(if $(HYBRID_MALLOC),sheap.o) \
$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
$(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ)
obj = $(base_obj) $(NS_OBJC_OBJ)
Bset_mark = 0163, /* this loser is no longer generated as of v18 */
#endif
};
+
+ /* Whether to maintain a `top' and `bottom' field in the stack frame. */
+ #define BYTE_MAINTAIN_TOP BYTE_CODE_SAFE
\f
- /* Fetch the next byte from the bytecode stream. */
+ /* Structure describing a value stack used during byte-code execution
+ in Fbyte_code. */
+
+ struct byte_stack
+ {
+ /* Program counter. This points into the byte_string below
+ and is relocated when that string is relocated. */
+ const unsigned char *pc;
+
+ /* Top and bottom of stack. The bottom points to an area of memory
+ allocated with alloca in Fbyte_code. */
+ #if BYTE_MAINTAIN_TOP
+ Lisp_Object *top, *bottom;
+ #endif
+
+ /* The string containing the byte-code, and its current address.
+ Storing this here protects it from GC because mark_byte_stack
+ marks it. */
+ Lisp_Object byte_string;
+ const unsigned char *byte_string_start;
+
+ /* Next entry in byte_stack_list. */
+ struct byte_stack *next;
+ };
+
+ /* A list of currently active byte-code execution value stacks.
+ Fbyte_code adds an entry to the head of this list before it starts
+ processing byte-code, and it removes the entry again when it is
- done. Signaling an error truncates the list. */
++ done. Signaling an error truncates the list.
+
++ byte_stack_list is a macro defined in thread.h. */
+ /* struct byte_stack *byte_stack_list; */
+
+ \f
+ /* Relocate program counters in the stacks on byte_stack_list. Called
+ when GC has completed. */
+
+ void
+ relocate_byte_stack (struct byte_stack *stack)
+ {
+ for (; stack; stack = stack->next)
+ {
+ if (stack->byte_string_start != SDATA (stack->byte_string))
+ {
+ ptrdiff_t offset = stack->pc - stack->byte_string_start;
+ stack->byte_string_start = SDATA (stack->byte_string);
+ stack->pc = stack->byte_string_start + offset;
+ }
+ }
+ }
- #define FETCH (*pc++)
+ \f
+ /* Fetch the next byte from the bytecode stream. */
-
+ #ifdef BYTE_CODE_SAFE
+ #define FETCH (eassert (stack.byte_string_start == SDATA (stack.byte_string)), *stack.pc++)
+ #else
+ #define FETCH *stack.pc++
+ #endif
/* Fetch two bytes from the bytecode stream and make a 16-bit number
out of them. */
#define TOP (*top)
-/* Actions that must be performed before and after calling a function
- that might GC. */
-
-#if !BYTE_MAINTAIN_TOP
-#define BEFORE_POTENTIAL_GC() ((void)0)
-#define AFTER_POTENTIAL_GC() ((void)0)
-#else
-#define BEFORE_POTENTIAL_GC() stack.top = top
-#define AFTER_POTENTIAL_GC() stack.top = NULL
-#endif
-
-/* Garbage collect if we have consed enough since the last time.
- We do this at every branch, to avoid loops that never GC. */
-
-#define MAYBE_GC() \
- do { \
- BEFORE_POTENTIAL_GC (); \
- maybe_gc (); \
- AFTER_POTENTIAL_GC (); \
- } while (0)
-
-/* Check for jumping out of range. */
-
-#ifdef BYTE_CODE_SAFE
-
-#define CHECK_RANGE(ARG) \
- if (ARG >= bytestr_length) emacs_abort ()
-
-#else /* not BYTE_CODE_SAFE */
-
-#define CHECK_RANGE(ARG)
-
-#endif /* not BYTE_CODE_SAFE */
++#define CHECK_RANGE(ARG) \
++ (BYTE_CODE_SAFE && bytestr_length <= (ARG) ? emacs_abort () : (void) 0)
+
+ /* A version of the QUIT macro which makes sure that the stack top is
+ set before signaling `quit'. */
-
+ #define BYTE_CODE_QUIT \
+ do { \
++ if (quitcounter++) \
++ break; \
++ maybe_gc (); \
+ if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \
+ { \
- Lisp_Object flag = Vquit_flag; \
++ Lisp_Object flag = Vquit_flag; \
+ Vquit_flag = Qnil; \
- BEFORE_POTENTIAL_GC (); \
+ if (EQ (Vthrow_on_input, flag)) \
+ Fthrow (Vthrow_on_input, Qt); \
- Fsignal (Qquit, Qnil); \
- AFTER_POTENTIAL_GC (); \
++ quit (); \
+ } \
+ else if (pending_signals) \
+ process_pending_signals (); \
+ } while (0)
+
+
DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
doc: /* Function used internally in byte-compiled code.
The first argument, BYTESTR, is a string of byte code;
convert them back to the originally intended unibyte form. */
bytestr = Fstring_as_unibyte (bytestr);
-#ifdef BYTE_CODE_SAFE
- bytestr_length = SBYTES (bytestr);
-#endif
- vectorp = XVECTOR (vector)->contents;
+ ptrdiff_t bytestr_length = SBYTES (bytestr);
+ Lisp_Object *vectorp = XVECTOR (vector)->contents;
++ struct byte_stack stack;
- unsigned char quitcounter = 1;
+ stack.byte_string = bytestr;
+ stack.pc = stack.byte_string_start = SDATA (bytestr);
- if (MAX_ALLOCA / word_size <= XFASTINT (maxdepth))
- memory_full (SIZE_MAX);
- top = alloca ((XFASTINT (maxdepth) + 1) * sizeof *top);
-#if BYTE_MAINTAIN_TOP
- stack.bottom = top + 1;
- stack.top = NULL;
-#endif
++ unsigned char quitcounter = 0;
+ EMACS_INT stack_items = XFASTINT (maxdepth) + 1;
+ USE_SAFE_ALLOCA;
+ Lisp_Object *stack_base;
- SAFE_ALLOCA_LISP_EXTRA (stack_base, stack_items, bytestr_length);
++ SAFE_ALLOCA_LISP (stack_base, stack_items);
+ Lisp_Object *stack_lim = stack_base + stack_items;
+ Lisp_Object *top = stack_base;
- memcpy (stack_lim, SDATA (bytestr), bytestr_length);
- void *void_stack_lim = stack_lim;
- unsigned char const *bytestr_data = void_stack_lim;
- unsigned char const *pc = bytestr_data;
+ stack.next = byte_stack_list;
+ byte_stack_list = &stack;
+ ptrdiff_t count = SPECPDL_INDEX ();
-#ifdef BYTE_CODE_SAFE
- stacke = stack.bottom - 1 + XFASTINT (maxdepth);
-#endif
-
- if (INTEGERP (args_template))
+ if (!NILP (args_template))
{
+ eassert (INTEGERP (args_template));
ptrdiff_t at = XINT (args_template);
bool rest = (at & 128) != 0;
int mandatory = at & 127;
CASE (Bgotoifnil):
{
- Lisp_Object v1 = POP;
+ Lisp_Object v1;
- MAYBE_GC ();
op = FETCH2;
+ v1 = POP;
if (NILP (v1))
- goto op_branch;
+ {
+ BYTE_CODE_QUIT;
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
+ }
NEXT;
}
NEXT;
CASE (Bgoto):
- op = FETCH2;
- op_branch:
- op -= pc - bytestr_data;
- op_relative_branch:
- if (BYTE_CODE_SAFE
- && ! (bytestr_data - pc <= op
- && op < bytestr_data + bytestr_length - pc))
- emacs_abort ();
- quitcounter += op < 0;
- if (!quitcounter)
- {
- quitcounter = 1;
- maybe_gc ();
- QUIT;
- }
- pc += op;
- MAYBE_GC ();
+ BYTE_CODE_QUIT;
- op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
++ op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
NEXT;
CASE (Bgotoifnonnil):
- {
- Lisp_Object v1;
- MAYBE_GC ();
- op = FETCH2;
- v1 = POP;
- if (!NILP (v1))
- {
- BYTE_CODE_QUIT;
- CHECK_RANGE (op);
- stack.pc = stack.byte_string_start + op;
- }
- NEXT;
- }
+ op = FETCH2;
- if (!NILP (POP))
- goto op_branch;
++ Lisp_Object v1 = POP;
++ if (!NILP (v1))
++ {
++ BYTE_CODE_QUIT;
++ CHECK_RANGE (op);
++ stack.pc = stack.byte_string_start + op;
++ }
+ NEXT;
CASE (Bgotoifnilelsepop):
- MAYBE_GC ();
op = FETCH2;
if (NILP (TOP))
- goto op_branch;
- DISCARD (1);
+ {
+ BYTE_CODE_QUIT;
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
+ }
- else DISCARD (1);
NEXT;
CASE (Bgotoifnonnilelsepop):
- MAYBE_GC ();
op = FETCH2;
if (!NILP (TOP))
- goto op_branch;
- DISCARD (1);
+ {
+ BYTE_CODE_QUIT;
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
+ }
+ else DISCARD (1);
NEXT;
CASE (BRgoto):
- op = FETCH - 128;
- goto op_relative_branch;
- MAYBE_GC ();
+ BYTE_CODE_QUIT;
+ stack.pc += (int) *stack.pc - 127;
+ NEXT;
CASE (BRgotoifnil):
- op = FETCH - 128;
- {
- Lisp_Object v1;
- MAYBE_GC ();
- v1 = POP;
- if (NILP (v1))
- {
- BYTE_CODE_QUIT;
- stack.pc += (int) *stack.pc - 128;
- }
- stack.pc++;
- NEXT;
- }
+ if (NILP (POP))
- goto op_relative_branch;
++ {
++ BYTE_CODE_QUIT;
++ stack.pc += (int) *stack.pc - 128;
++ }
++ stack.pc++;
+ NEXT;
CASE (BRgotoifnonnil):
- op = FETCH - 128;
- {
- Lisp_Object v1;
- MAYBE_GC ();
- v1 = POP;
- if (!NILP (v1))
- {
- BYTE_CODE_QUIT;
- stack.pc += (int) *stack.pc - 128;
- }
- stack.pc++;
- NEXT;
- }
+ if (!NILP (POP))
- goto op_relative_branch;
++ {
++ BYTE_CODE_QUIT;
++ stack.pc += (int) *stack.pc - 128;
++ }
++ stack.pc++;
+ NEXT;
CASE (BRgotoifnilelsepop):
- op = FETCH - 128;
- MAYBE_GC ();
+ op = *stack.pc++;
if (NILP (TOP))
- goto op_relative_branch;
- DISCARD (1);
+ {
+ BYTE_CODE_QUIT;
+ stack.pc += op - 128;
+ }
+ else DISCARD (1);
NEXT;
CASE (BRgotoifnonnilelsepop):
- op = FETCH - 128;
- MAYBE_GC ();
+ op = *stack.pc++;
if (!NILP (TOP))
- goto op_relative_branch;
- DISCARD (1);
+ {
+ BYTE_CODE_QUIT;
+ stack.pc += op - 128;
+ }
+ else DISCARD (1);
NEXT;
CASE (Breturn):
if (sys_setjmp (c->jmp))
{
struct handler *c = handlerlist;
- int dest;
++ int desc;
top = c->bytecode_top;
- op = c->bytecode_dest;
+ dest = c->bytecode_dest;
handlerlist = c->next;
PUSH (c->val);
- goto op_branch;
+ CHECK_RANGE (dest);
+ /* Might have been re-set by longjmp! */
+ stack.byte_string_start = SDATA (stack.byte_string);
+ stack.pc = stack.byte_string_start + dest;
}
NEXT;
call3 (Qerror,
build_string ("Invalid byte opcode: op=%s, ptr=%d"),
make_number (op),
- make_number (pc - 1 - bytestr_data));
- make_number ((stack.pc - 1) - stack.byte_string_start));
++ make_number (stack.pc - 1 - stack.byte_string_start));
/* Handy byte-codes for lexical binding. */
CASE (Bstack_ref1):
bool display_arg;
#endif
- /* An address near the bottom of the stack.
- Tells GC how to save a copy of the stack. */
- char *stack_bottom;
-#if defined (DOUG_LEA_MALLOC) || defined (GNU_LINUX)
-/* The address where the heap starts (from the first sbrk (0) call). */
-static void *my_heap_start;
-#endif
--
-#ifdef GNU_LINUX
+#if defined GNU_LINUX && !defined CANNOT_DUMP
/* The gap between BSS end and heap start as far as we can tell. */
static uprintmax_t heap_bss_diff;
#endif
/* If we use --chdir, this records the original directory. */
char *original_pwd = 0;
- stack_base = &dummy;
+ /* Record (approximately) where the stack begins. */
+ stack_bottom = &stack_bottom_variable;
+ dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0
+ || strcmp (argv[argc - 1], "bootstrap") == 0);
+
+ /* True if address randomization interferes with memory allocation. */
+# ifdef __PPC64__
+ bool disable_aslr = true;
+# else
+ bool disable_aslr = dumping;
+# endif
+
+ if (disable_aslr && disable_address_randomization ())
+ {
+ /* Set this so the personality will be reverted before execs
+ after this one. */
+ xputenv ("EMACS_HEAP_EXEC=true");
+
+ /* Address randomization was enabled, but is now disabled.
+ Re-execute Emacs to get a clean slate. */
+ execvp (argv[0], argv);
+
+ /* If the exec fails, warn and then try anyway. */
+ perror (argv[0]);
+ }
+
#ifndef CANNOT_DUMP
might_dump = !initialized;
-#endif
-#ifdef GNU_LINUX
+# ifdef GNU_LINUX
if (!initialized)
{
- if (my_heap_start == 0)
- my_heap_start = sbrk (0);
-
- heap_bss_diff = (char *)my_heap_start - max (my_endbss, my_endbss_static);
+ char *heap_start = my_heap_start ();
+ heap_bss_diff = heap_start - max (my_endbss, my_endbss_static);
}
+# endif
#endif
#if defined WINDOWSNT || defined HAVE_NTGUI
is shutting down. */
Lisp_Object Vrun_hooks;
++/* The commented-out variables below are macros defined in thread.h. */
++
/* Current number of specbindings allocated in specpdl, not counting
the dummy entry specpdl[-1]. */
/* Depth in Lisp evaluations and function calls. */
- static EMACS_INT lisp_eval_depth;
-/* EMACS_INT lisp_eval_depth; */
++/* static EMACS_INT lisp_eval_depth; */
/* The value of num_nonmacro_input_events as of the last time we
started to enter the debugger. If we decide to enter the debugger
{ /* Put a dummy catcher at top-level so that handlerlist is never NULL.
This is important since handlerlist->nextfree holds the freelist
which would otherwise leak every time we unwind back to top-level. */
- handlerlist = handlerlist_sentinel.nextfree = &handlerlist_sentinel;
- struct handler *c;
+ handlerlist_sentinel = xzalloc (sizeof (struct handler));
+ handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
- PUSH_HANDLER (c, Qunbound, CATCHER);
+ struct handler *c = push_handler (Qunbound, CATCHER);
- eassert (c == &handlerlist_sentinel);
- handlerlist_sentinel.nextfree = NULL;
- handlerlist_sentinel.next = NULL;
+ eassert (c == handlerlist_sentinel);
+ handlerlist_sentinel->nextfree = NULL;
+ handlerlist_sentinel->next = NULL;
}
Vquit_flag = Qnil;
debug_on_next_call = 0;
Lisp_Object val = handlerlist->val;
clobbered_eassert (handlerlist == c);
handlerlist = handlerlist->next;
- return (*hfun) (val, nargs, args);
+ return hfun (val, nargs, args);
}
+ else
+ {
+ Lisp_Object val = bfun (nargs, args);
+ clobbered_eassert (handlerlist == c);
+ handlerlist = handlerlist->next;
+ return val;
+ }
+}
- val = (*bfun) (nargs, args);
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
+struct handler *
+push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype)
+{
+ struct handler *c = push_handler_nosignal (tag_ch_val, handlertype);
+ if (!c)
+ memory_full (sizeof *c);
+ return c;
+}
+
+struct handler *
+push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype)
+{
+ struct handler *c = handlerlist->nextfree;
+ if (!c)
+ {
+ c = malloc (sizeof *c);
+ if (!c)
+ return c;
+ if (profiler_memory_running)
+ malloc_probe (sizeof *c);
+ c->nextfree = NULL;
+ handlerlist->nextfree = c;
+ }
+ c->type = handlertype;
+ c->tag_or_ch = tag_ch_val;
+ c->val = Qnil;
+ c->next = handlerlist;
+ c->lisp_eval_depth = lisp_eval_depth;
+ c->pdlcount = SPECPDL_INDEX ();
+ c->poll_suppress_count = poll_suppress_count;
+ c->interrupt_input_blocked = interrupt_input_blocked;
++ c->byte_stack = byte_stack_list;
+ handlerlist = c;
+ return c;
}
\f
return 0;
}
- if (!sym->constant)
+ void
+ do_specbind (struct Lisp_Symbol *sym, union specbinding *bind,
+ Lisp_Object value)
+ {
+ switch (sym->redirect)
+ {
+ case SYMBOL_PLAINVAL:
- set_internal (specpdl_symbol (bind), value, Qnil, 1);
++ if (!sym->trapped_write)
+ SET_SYMBOL_VAL (sym, value);
+ else
- set_internal (specpdl_symbol (bind), value, Qnil, 1);
++ set_internal (specpdl_symbol (bind), value, Qnil, SET_INTERNAL_BIND);
+ break;
+
+ case SYMBOL_LOCALIZED:
+ case SYMBOL_FORWARDED:
+ if ((sym->redirect == SYMBOL_LOCALIZED
+ || BUFFER_OBJFWDP (SYMBOL_FWD (sym)))
+ && CONSP (specpdl_symbol (bind)))
+ {
+ Lisp_Object where;
+
+ where = XCAR (XCDR (specpdl_symbol (bind)));
+ if (NILP (where)
+ && sym->redirect == SYMBOL_FORWARDED)
+ {
+ Fset_default (XCAR (specpdl_symbol (bind)), value);
+ return;
+ }
+ }
+
- abort ();
++ set_internal (specpdl_symbol (bind), value, Qnil, SET_INTERNAL_BIND);
+ break;
+
+ default:
++ emacs_abort ();
+ }
+ }
+
/* `specpdl_ptr' describes which variable is
let-bound, so it can be properly undone when we unbind_to.
It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
grow_specpdl ();
}
+ void
+ rebind_for_thread_switch (void)
+ {
+ union specbinding *bind;
+
+ for (bind = specpdl; bind != specpdl_ptr; ++bind)
+ {
+ if (bind->kind >= SPECPDL_LET)
+ {
+ Lisp_Object value = specpdl_saved_value (bind);
+
+ bind->let.saved_value = Qnil;
+ do_specbind (XSYMBOL (specpdl_symbol (bind)), bind, value);
+ }
+ }
+ }
+
static void
- { /* If variable has a trivial value (no forwarding), we can
- just set it. No need to check for constant symbols here,
- since that was already done by specbind. */
- struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (this_binding));
- if (sym->redirect == SYMBOL_PLAINVAL)
+ do_one_unbind (union specbinding *this_binding, int unwinding)
+ {
+ eassert (unwinding || this_binding->kind >= SPECPDL_LET);
+ switch (this_binding->kind)
+ {
+ case SPECPDL_UNWIND:
+ this_binding->unwind.func (this_binding->unwind.arg);
+ break;
+ case SPECPDL_UNWIND_PTR:
+ this_binding->unwind_ptr.func (this_binding->unwind_ptr.arg);
+ break;
+ case SPECPDL_UNWIND_INT:
+ this_binding->unwind_int.func (this_binding->unwind_int.arg);
+ break;
+ case SPECPDL_UNWIND_VOID:
+ this_binding->unwind_void.func ();
+ break;
+ case SPECPDL_BACKTRACE:
+ break;
+ case SPECPDL_LET:
- SET_SYMBOL_VAL (sym, specpdl_old_value (this_binding));
++ { /* If variable has a trivial value (no forwarding), and isn't
++ trapped we can just set it. No need to check for constant
++ symbols here, since that was already done by specbind. */
++ struct Lisp_Symbol sym = specpdl_symbol (this_binding);
++ if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL)
+ {
- set_internal (symbol, old_value, where, 1);
++ if (XSYMBOL (sym)->trapped_write == SYMBOL_UNTRAPPED_WRITE)
++ SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value (this_binding));
++ else
++ set_internal (sym, specpdl_old_value (this_binding),
++ Qnil, SET_INTERNAL_UNBIND);
+ break;
+ }
+ else
+ { /* FALLTHROUGH!!
+ NOTE: we only ever come here if make_local_foo was used for
+ the first time on this var within this let. */
+ }
+ }
+ case SPECPDL_LET_DEFAULT:
+ Fset_default (specpdl_symbol (this_binding),
+ specpdl_old_value (this_binding));
+ break;
+ case SPECPDL_LET_LOCAL:
+ {
+ Lisp_Object symbol = specpdl_symbol (this_binding);
+ Lisp_Object where = specpdl_where (this_binding);
+ Lisp_Object old_value = specpdl_old_value (this_binding);
+ eassert (BUFFERP (where));
+
+ /* If this was a local binding, reset the value in the appropriate
+ buffer, but only if that buffer's binding still exists. */
+ if (!NILP (Flocal_variable_p (symbol, where)))
++ set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND);
+ }
+ break;
+ }
+ }
+
+ void
do_nothing (void)
{}
PVEC_WINDOW_CONFIGURATION,
PVEC_SUBR,
PVEC_OTHER,
-
+ PVEC_XWIDGET,
+ PVEC_XWIDGET_VIEW,
+ PVEC_THREAD,
+ PVEC_MUTEX,
+ PVEC_CONDVAR,
/* These should be last, check internal_equal to see why. */
PVEC_COMPILED,
PVEC_CHAR_TABLE,
ptrdiff_t pdlcount;
int poll_suppress_count;
int interrupt_input_blocked;
+ struct byte_stack *byte_stack;
};
-/* Fill in the components of c, and put it on the list. */
-#define PUSH_HANDLER(c, tag_ch_val, handlertype) \
- if (handlerlist->nextfree) \
- (c) = handlerlist->nextfree; \
- else \
- { \
- (c) = xmalloc (sizeof (struct handler)); \
- (c)->nextfree = NULL; \
- handlerlist->nextfree = (c); \
- } \
- (c)->type = (handlertype); \
- (c)->tag_or_ch = (tag_ch_val); \
- (c)->val = Qnil; \
- (c)->next = handlerlist; \
- (c)->f_lisp_eval_depth = lisp_eval_depth; \
- (c)->pdlcount = SPECPDL_INDEX (); \
- (c)->poll_suppress_count = poll_suppress_count; \
- (c)->interrupt_input_blocked = interrupt_input_blocked;\
- (c)->byte_stack = byte_stack_list; \
- handlerlist = (c);
-
-
extern Lisp_Object memory_signal_data;
- /* An address near the bottom of the stack.
- Tells GC how to save a copy of the stack. */
- extern char *stack_bottom;
-
/* Check quit-flag and quit if it is non-nil.
Typing C-g does not directly cause a quit; it only sets Vquit_flag.
So the program needs to do QUIT at times when it is safe to quit.
#if defined REL_ALLOC && !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
extern void refill_memory_reserve (void);
#endif
+extern void alloc_unexec_pre (void);
+extern void alloc_unexec_post (void);
+ extern void mark_stack (char *, char *);
+ extern void flush_stack_call_func (void (*func) (void *arg), void *arg);
extern const char *pending_malloc_warning;
extern Lisp_Object zero_vector;
- extern Lisp_Object *stack_base;
extern EMACS_INT consing_since_gc;
extern EMACS_INT gc_relative_threshold;
extern EMACS_INT memory_full_cons_threshold;
extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
extern bool let_shadows_global_binding_p (Lisp_Object symbol);
+#ifdef HAVE_MODULES
+/* Defined in alloc.c. */
+extern Lisp_Object make_user_ptr (void (*finalizer) (void *), void *p);
+
+/* Defined in emacs-module.c. */
+extern void module_init (void);
+extern void syms_of_module (void);
+#endif
+ /* Defined in thread.c. */
+ extern void mark_threads (void);
+
/* Defined in editfns.c. */
extern void insert1 (Lisp_Object);
extern Lisp_Object save_excursion_save (void);
/* Defined in bytecode.c. */
extern void syms_of_bytecode (void);
+ extern void relocate_byte_stack (struct byte_stack *);
++extern struct byte_stack *byte_stack_list;
extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, ptrdiff_t, Lisp_Object *);
+extern Lisp_Object get_byte_code_arity (Lisp_Object);
/* Defined in macros.c. */
extern void init_macros (void);
#endif
#endif
+#if defined HAVE_GETADDRINFO_A || defined HAVE_GNUTLS
+/* This is 0.1s in nanoseconds. */
+#define ASYNC_RETRY_NSEC 100000000
+#endif
+
#ifdef WINDOWSNT
extern int sys_select (int, fd_set *, fd_set *, fd_set *,
- struct timespec *, void *);
+ struct timespec *, sigset_t *);
#endif
-/* Work around GCC 4.7.0 bug with strict overflow checking; see
+/* Work around GCC 4.3.0 bug with strict overflow checking; see
<http://gcc.gnu.org/bugzilla/show_bug.cgi?id=52904>.
This bug appears to be fixed in GCC 5.1, so don't work around it there. */
-#if __GNUC__ == 4 && __GNUC_MINOR__ >= 3
+#if GNUC_PREREQ (4, 3, 0) && ! GNUC_PREREQ (5, 1, 0)
# pragma GCC diagnostic ignored "-Wstrict-overflow"
#endif
\f
static void deactivate_process (Lisp_Object);
static int status_notify (struct Lisp_Process *, struct Lisp_Process *);
static int read_process_output (Lisp_Object, int);
-static void handle_child_signal (int);
static void create_pty (Lisp_Object);
+static void exec_sentinel (Lisp_Object, Lisp_Object);
- /* Mask of bits indicating the descriptors that we wait for input on. */
-
- static fd_set input_wait_mask;
-
- /* Mask that excludes keyboard input descriptor(s). */
-
- static fd_set non_keyboard_wait_mask;
-
- /* Mask that excludes process input descriptor(s). */
-
- static fd_set non_process_wait_mask;
-
- /* Mask for selecting for write. */
-
- static fd_set write_mask;
-
- /* Mask of bits indicating the descriptors that we wait for connect to
- complete on. Once they complete, they are removed from this mask
- and added to the input_wait_mask and non_keyboard_wait_mask. */
-
- static fd_set connect_wait_mask;
-static Lisp_Object get_process (register Lisp_Object name);
-static void exec_sentinel (Lisp_Object proc, Lisp_Object reason);
--
-#ifdef NON_BLOCKING_CONNECT
/* Number of bits set in connect_wait_mask. */
static int num_pending_connects;
-#endif /* NON_BLOCKING_CONNECT */
- /* The largest descriptor currently in use for a process object; -1 if none. */
- static int max_process_desc;
-
- /* The largest descriptor currently in use for input; -1 if none. */
- static int max_input_desc;
+ /* The largest descriptor currently in use; -1 if none. */
+ static int max_desc;
+/* Set the external socket descriptor for Emacs to use when
+ `make-network-process' is called with a non-nil
+ `:use-external-socket' option. The value should be either -1, or
+ the file descriptor of a socket that is already bound. */
+static int external_sock_fd;
+
/* Indexed by descriptor, gives the process (if any) for that descriptor. */
static Lisp_Object chan_process[FD_SETSIZE];
+static void wait_for_socket_fds (Lisp_Object, char const *);
/* Alist of elements (NAME . PROCESS). */
static Lisp_Object Vprocess_alist;
fd_callback_info[fd].func = func;
fd_callback_info[fd].data = data;
- fd_callback_info[fd].condition |= FOR_WRITE;
+ fd_callback_info[fd].flags |= FOR_WRITE;
}
- /* FD is no longer an input descriptor; update max_input_desc accordingly. */
+ static void
+ add_non_blocking_write_fd (int fd)
+ {
+ eassert (fd >= 0 && fd < FD_SETSIZE);
+ eassert (fd_callback_info[fd].func == NULL);
+
+ fd_callback_info[fd].flags |= FOR_WRITE | NON_BLOCKING_CONNECT_FD;
+ if (fd > max_desc)
+ max_desc = fd;
-#ifdef NON_BLOCKING_CONNECT
+ ++num_pending_connects;
-#endif
+ }
static void
- delete_input_desc (int fd)
+ recompute_max_desc (void)
{
- if (fd == max_input_desc)
- {
- do
- fd--;
- while (0 <= fd && ! (FD_ISSET (fd, &input_wait_mask)
- || FD_ISSET (fd, &write_mask)));
+ int fd;
- max_input_desc = fd;
+ for (fd = max_desc; fd >= 0; --fd)
+ {
+ if (fd_callback_info[fd].flags != 0)
+ {
+ max_desc = fd;
+ break;
+ }
}
}
void
delete_write_fd (int fd)
{
- FD_CLR (fd, &write_mask);
- fd_callback_info[fd].condition &= ~FOR_WRITE;
- if (fd_callback_info[fd].condition == 0)
+ int lim = max_desc;
+
-#ifdef NON_BLOCKING_CONNECT
+ if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0)
+ {
+ if (--num_pending_connects < 0)
- abort ();
++ emacs_abort ();
+ }
-#endif
+ fd_callback_info[fd].flags &= ~(FOR_WRITE | NON_BLOCKING_CONNECT_FD);
+ if (fd_callback_info[fd].flags == 0)
{
fd_callback_info[fd].func = 0;
fd_callback_info[fd].data = 0;
deactivate_process (proc);
}
+ void
+ update_processes_for_thread_death (Lisp_Object dying_thread)
+ {
+ Lisp_Object pair;
+
+ for (pair = Vprocess_alist; !NILP (pair); pair = XCDR (pair))
+ {
+ Lisp_Object process = XCDR (XCAR (pair));
+ if (EQ (XPROCESS (process)->thread, dying_thread))
+ {
+ struct Lisp_Process *proc = XPROCESS (process);
+
+ proc->thread = Qnil;
+ if (proc->infd >= 0)
+ fd_callback_info[proc->infd].thread = NULL;
+ if (proc->outfd >= 0)
+ fd_callback_info[proc->outfd].thread = NULL;
+ }
+ }
+ }
+
+#ifdef HAVE_GETADDRINFO_A
+static void
+free_dns_request (Lisp_Object proc)
+{
+ struct Lisp_Process *p = XPROCESS (proc);
+
+ if (p->dns_request->ar_result)
+ freeaddrinfo (p->dns_request->ar_result);
+ xfree (p->dns_request);
+ p->dns_request = NULL;
+}
+#endif
+
\f
DEFUN ("processp", Fprocessp, Sprocessp, 1, 1, 0,
doc: /* Return t if OBJECT is a process. */)
return XPROCESS (process)->mark;
}
- {
- FD_CLR (p->infd, &input_wait_mask);
- FD_CLR (p->infd, &non_keyboard_wait_mask);
- }
+static void
+set_process_filter_masks (struct Lisp_Process *p)
+{
+ if (EQ (p->filter, Qt) && !EQ (p->status, Qlisten))
- {
- FD_SET (p->infd, &input_wait_mask);
- FD_SET (p->infd, &non_keyboard_wait_mask);
- }
++ delete_read_fd (p->infd);
+ else if (EQ (p->filter, Qt)
+ /* Network or serial process not stopped: */
+ && !EQ (p->command, Qt))
++ add_read_fd (p->infd);
+}
+
DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter,
2, 2, 0,
doc: /* Give PROCESS the filter function FILTER; nil means default.
return XPROCESS (process)->sentinel;
}
+ DEFUN ("set-process-thread", Fset_process_thread, Sset_process_thread,
+ 2, 2, 0,
+ doc: /* FIXME */)
+ (Lisp_Object process, Lisp_Object thread)
+ {
+ struct Lisp_Process *proc;
+ struct thread_state *tstate;
+
+ CHECK_PROCESS (process);
+ if (NILP (thread))
+ tstate = NULL;
+ else
+ {
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+ }
+
+ proc = XPROCESS (process);
+ proc->thread = thread;
+ if (proc->infd >= 0)
+ fd_callback_info[proc->infd].thread = tstate;
+ if (proc->outfd >= 0)
+ fd_callback_info[proc->outfd].thread = tstate;
+
+ return thread;
+ }
+
+ DEFUN ("process-thread", Fprocess_thread, Sprocess_thread,
+ 1, 1, 0,
+ doc: /* FIXME */)
+ (Lisp_Object process)
+ {
+ CHECK_PROCESS (process);
+ return XPROCESS (process)->thread;
+ }
+
DEFUN ("set-process-window-size", Fset_process_window_size,
Sset_process_window_size, 3, 3, 0,
- doc: /* Tell PROCESS that it has logical window size HEIGHT and WIDTH. */)
+ doc: /* Tell PROCESS that it has logical window size WIDTH by HEIGHT.
+Value is t if PROCESS was successfully told about the window size,
+nil otherwise. */)
(Lisp_Object process, Lisp_Object height, Lisp_Object width)
{
CHECK_PROCESS (process);
return proc;
}
-/* Create a network stream/datagram client/server process. Treated
- exactly like a normal process when reading and writing. Primary
- differences are in status display and process deletion. A network
- connection has no PID; you cannot signal it. All you can do is
- stop/continue it and deactivate/close it via delete-process. */
+static void
+set_network_socket_coding_system (Lisp_Object proc, Lisp_Object host,
+ Lisp_Object service, Lisp_Object name)
+{
+ Lisp_Object tem;
+ struct Lisp_Process *p = XPROCESS (proc);
+ Lisp_Object contact = p->childp;
+ Lisp_Object coding_systems = Qt;
+ Lisp_Object val;
-DEFUN ("make-network-process", Fmake_network_process, Smake_network_process,
- 0, MANY, 0,
- doc: /* Create and return a network server or client process.
+ tem = Fplist_member (contact, QCcoding);
+ if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem))))
+ tem = Qnil; /* No error message (too late!). */
-In Emacs, network connections are represented by process objects, so
-input and output work as for subprocesses and `delete-process' closes
-a network connection. However, a network process has no process id,
-it cannot be signaled, and the status codes are different from normal
-processes.
+ /* Setup coding systems for communicating with the network stream. */
+ /* Qt denotes we have not yet called Ffind_operation_coding_system. */
-Arguments are specified as keyword/argument pairs. The following
-arguments are defined:
+ if (!NILP (tem))
+ {
+ val = XCAR (XCDR (tem));
+ if (CONSP (val))
+ val = XCAR (val);
+ }
+ else if (!NILP (Vcoding_system_for_read))
+ val = Vcoding_system_for_read;
+ else if ((!NILP (p->buffer)
+ && NILP (BVAR (XBUFFER (p->buffer), enable_multibyte_characters)))
+ || (NILP (p->buffer)
+ && NILP (BVAR (&buffer_defaults, enable_multibyte_characters))))
+ /* We dare not decode end-of-line format by setting VAL to
+ Qraw_text, because the existing Emacs Lisp libraries
+ assume that they receive bare code including a sequence of
+ CR LF. */
+ val = Qnil;
+ else
+ {
+ if (NILP (host) || NILP (service))
+ coding_systems = Qnil;
+ else
+ coding_systems = CALLN (Ffind_operation_coding_system,
+ Qopen_network_stream, name, p->buffer,
+ host, service);
+ if (CONSP (coding_systems))
+ val = XCAR (coding_systems);
+ else if (CONSP (Vdefault_process_coding_system))
+ val = XCAR (Vdefault_process_coding_system);
+ else
+ val = Qnil;
+ }
+ pset_decode_coding_system (p, val);
-:name NAME -- NAME is name for process. It is modified if necessary
-to make it unique.
+ if (!NILP (tem))
+ {
+ val = XCAR (XCDR (tem));
+ if (CONSP (val))
+ val = XCDR (val);
+ }
+ else if (!NILP (Vcoding_system_for_write))
+ val = Vcoding_system_for_write;
+ else if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
+ val = Qnil;
+ else
+ {
+ if (EQ (coding_systems, Qt))
+ {
+ if (NILP (host) || NILP (service))
+ coding_systems = Qnil;
+ else
+ coding_systems = CALLN (Ffind_operation_coding_system,
+ Qopen_network_stream, name, p->buffer,
+ host, service);
+ }
+ if (CONSP (coding_systems))
+ val = XCDR (coding_systems);
+ else if (CONSP (Vdefault_process_coding_system))
+ val = XCDR (Vdefault_process_coding_system);
+ else
+ val = Qnil;
+ }
+ pset_encode_coding_system (p, val);
-:buffer BUFFER -- BUFFER is the buffer (or buffer-name) to associate
-with the process. Process output goes at end of that buffer, unless
-you specify an output stream or filter function to handle the output.
-BUFFER may be also nil, meaning that this process is not associated
-with any buffer.
+ pset_decoding_buf (p, empty_unibyte_string);
+ p->decoding_carryover = 0;
+ pset_encoding_buf (p, empty_unibyte_string);
-:host HOST -- HOST is name of the host to connect to, or its IP
-address. The symbol `local' specifies the local host. If specified
-for a server process, it must be a valid name or address for the local
-host, and only clients connecting to that address will be accepted.
+ p->inherit_coding_system_flag
+ = !(!NILP (tem) || NILP (p->buffer) || !inherit_process_coding_system);
+}
-:service SERVICE -- SERVICE is name of the service desired, or an
-integer specifying a port number to connect to. If SERVICE is t,
-a random port number is selected for the server. (If Emacs was
-compiled with getaddrinfo, a port number can also be specified as a
-string, e.g. "80", as well as an integer. This is not portable.)
+#ifdef HAVE_GNUTLS
+static void
+finish_after_tls_connection (Lisp_Object proc)
+{
+ struct Lisp_Process *p = XPROCESS (proc);
+ Lisp_Object contact = p->childp;
+ Lisp_Object result = Qt;
-:type TYPE -- TYPE is the type of connection. The default (nil) is a
-stream type connection, `datagram' creates a datagram type connection,
-`seqpacket' creates a reliable datagram connection.
+ if (!NILP (Ffboundp (Qnsm_verify_connection)))
+ result = call3 (Qnsm_verify_connection,
+ proc,
+ Fplist_get (contact, QChost),
+ Fplist_get (contact, QCservice));
-:family FAMILY -- FAMILY is the address (and protocol) family for the
-service specified by HOST and SERVICE. The default (nil) is to use
-whatever address family (IPv4 or IPv6) that is defined for the host
-and port number specified by HOST and SERVICE. Other address families
-supported are:
- local -- for a local (i.e. UNIX) address specified by SERVICE.
- ipv4 -- use IPv4 address family only.
- ipv6 -- use IPv6 address family only.
+ if (NILP (result))
+ {
+ pset_status (p, list2 (Qfailed,
+ build_string ("The Network Security Manager stopped the connections")));
+ deactivate_process (proc);
+ }
+ else if (p->outfd < 0)
+ {
+ /* The counterparty may have closed the connection (especially
+ if the NSM prompt above take a long time), so recheck the file
+ descriptor here. */
+ pset_status (p, Qfailed);
+ deactivate_process (proc);
+ }
+ else if (! FD_ISSET (p->outfd, &connect_wait_mask))
+ {
+ /* If we cleared the connection wait mask before we did the TLS
+ setup, then we have to say that the process is finally "open"
+ here. */
+ pset_status (p, Qrun);
+ /* Execute the sentinel here. If we had relied on status_notify
+ to do it later, it will read input from the process before
+ calling the sentinel. */
+ exec_sentinel (proc, build_string ("open\n"));
+ }
+}
+#endif
-:local ADDRESS -- ADDRESS is the local address used for the connection.
-This parameter is ignored when opening a client process. When specified
-for a server process, the FAMILY, HOST and SERVICE args are ignored.
+static void
+connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
+ Lisp_Object use_external_socket_p)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+ int s = -1, outch, inch;
+ int xerrno = 0;
+ int family;
+ struct sockaddr *sa = NULL;
+ int ret;
+ ptrdiff_t addrlen;
+ struct Lisp_Process *p = XPROCESS (proc);
+ Lisp_Object contact = p->childp;
+ int optbits = 0;
+ int socket_to_use = -1;
-:remote ADDRESS -- ADDRESS is the remote partner's address for the
-connection. This parameter is ignored when opening a stream server
-process. For a datagram server process, it specifies the initial
-setting of the remote datagram address. When specified for a client
-process, the FAMILY, HOST, and SERVICE args are ignored.
+ if (!NILP (use_external_socket_p))
+ {
+ socket_to_use = external_sock_fd;
-The format of ADDRESS depends on the address family:
-- An IPv4 address is represented as an vector of integers [A B C D P]
-corresponding to numeric IP address A.B.C.D and port number P.
-- A local address is represented as a string with the address in the
-local address space.
-- An "unsupported family" address is represented by a cons (F . AV)
-where F is the family number and AV is a vector containing the socket
-address data with one element per address data byte. Do not rely on
-this format in portable code, as it may depend on implementation
-defined constants, data sizes, and data structure alignment.
+ /* Ensure we don't consume the external socket twice. */
+ external_sock_fd = -1;
+ }
-:coding CODING -- If CODING is a symbol, it specifies the coding
-system used for both reading and writing for this process. If CODING
-is a cons (DECODING . ENCODING), DECODING is used for reading, and
-ENCODING is used for writing.
+ /* Do this in case we never enter the while-loop below. */
+ s = -1;
-:nowait BOOL -- If BOOL is non-nil for a stream type client process,
-return without waiting for the connection to complete; instead, the
-sentinel function will be called with second arg matching "open" (if
-successful) or "failed" when the connect completes. Default is to use
-a blocking connect (i.e. wait) for stream type connections.
+ while (!NILP (addrinfos))
+ {
+ Lisp_Object addrinfo = XCAR (addrinfos);
+ addrinfos = XCDR (addrinfos);
+ int protocol = XINT (XCAR (addrinfo));
+ Lisp_Object ip_address = XCDR (addrinfo);
-:noquery BOOL -- Query the user unless BOOL is non-nil, and process is
-running when Emacs is exited.
+#ifdef WINDOWSNT
+ retry_connect:
+#endif
-:stop BOOL -- Start process in the `stopped' state if BOOL non-nil.
-In the stopped state, a server process does not accept new
-connections, and a client process does not handle incoming traffic.
-The stopped state is cleared by `continue-process' and set by
-`stop-process'.
+ addrlen = get_lisp_to_sockaddr_size (ip_address, &family);
+ if (sa)
+ free (sa);
+ sa = xmalloc (addrlen);
+ conv_lisp_to_sockaddr (family, ip_address, sa, addrlen);
-:filter FILTER -- Install FILTER as the process filter.
+ s = socket_to_use;
+ if (s < 0)
+ {
+ int socktype = p->socktype | SOCK_CLOEXEC;
+ if (p->is_non_blocking_client)
+ socktype |= SOCK_NONBLOCK;
+ s = socket (family, socktype, protocol);
+ if (s < 0)
+ {
+ xerrno = errno;
+ continue;
+ }
+ }
-:filter-multibyte BOOL -- If BOOL is non-nil, strings given to the
-process filter are multibyte, otherwise they are unibyte.
-If this keyword is not specified, the strings are multibyte if
-the default value of `enable-multibyte-characters' is non-nil.
+ if (p->is_non_blocking_client && ! (SOCK_NONBLOCK && socket_to_use < 0))
+ {
+ ret = fcntl (s, F_SETFL, O_NONBLOCK);
+ if (ret < 0)
+ {
+ xerrno = errno;
+ emacs_close (s);
+ s = -1;
+ if (0 <= socket_to_use)
+ break;
+ continue;
+ }
+ }
-:sentinel SENTINEL -- Install SENTINEL as the process sentinel.
+#ifdef DATAGRAM_SOCKETS
+ if (!p->is_server && p->socktype == SOCK_DGRAM)
+ break;
+#endif /* DATAGRAM_SOCKETS */
-:log LOG -- Install LOG as the server process log function. This
-function is called when the server accepts a network connection from a
-client. The arguments are SERVER, CLIENT, and MESSAGE, where SERVER
-is the server process, CLIENT is the new process for the connection,
+ /* Make us close S if quit. */
+ record_unwind_protect_int (close_file_unwind, s);
+
+ /* Parse network options in the arg list. We simply ignore anything
+ which isn't a known option (including other keywords). An error
+ is signaled if setting a known option fails. */
+ {
+ Lisp_Object params = contact, key, val;
+
+ while (!NILP (params))
+ {
+ key = XCAR (params);
+ params = XCDR (params);
+ val = XCAR (params);
+ params = XCDR (params);
+ optbits |= set_socket_option (s, key, val);
+ }
+ }
+
+ if (p->is_server)
+ {
+ /* Configure as a server socket. */
+
+ /* SO_REUSEADDR = 1 is default for server sockets; must specify
+ explicit :reuseaddr key to override this. */
+#ifdef HAVE_LOCAL_SOCKETS
+ if (family != AF_LOCAL)
+#endif
+ if (!(optbits & (1 << OPIX_REUSEADDR)))
+ {
+ int optval = 1;
+ if (setsockopt (s, SOL_SOCKET, SO_REUSEADDR, &optval, sizeof optval))
+ report_file_error ("Cannot set reuse option on server socket", Qnil);
+ }
+
+ /* If passed a socket descriptor, it should be already bound. */
+ if (socket_to_use < 0 && bind (s, sa, addrlen) != 0)
+ report_file_error ("Cannot bind server socket", Qnil);
+
+#ifdef HAVE_GETSOCKNAME
+ if (p->port == 0)
+ {
+ struct sockaddr_in sa1;
+ socklen_t len1 = sizeof (sa1);
+ if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0)
+ {
+ Lisp_Object service;
+ service = make_number (ntohs (sa1.sin_port));
+ contact = Fplist_put (contact, QCservice, service);
+ /* Save the port number so that we can stash it in
+ the process object later. */
+ ((struct sockaddr_in *)sa)->sin_port = sa1.sin_port;
+ }
+ }
+#endif
+
+ if (p->socktype != SOCK_DGRAM && listen (s, p->backlog))
+ report_file_error ("Cannot listen on server socket", Qnil);
+
+ break;
+ }
+
+ immediate_quit = 1;
+ QUIT;
+
+ ret = connect (s, sa, addrlen);
+ xerrno = errno;
+
+ if (ret == 0 || xerrno == EISCONN)
+ {
+ /* The unwind-protect will be discarded afterwards.
+ Likewise for immediate_quit. */
+ break;
+ }
+
+ if (p->is_non_blocking_client && xerrno == EINPROGRESS)
+ break;
+
+#ifndef WINDOWSNT
+ if (xerrno == EINTR)
+ {
+ /* Unlike most other syscalls connect() cannot be called
+ again. (That would return EALREADY.) The proper way to
+ wait for completion is pselect(). */
+ int sc;
+ socklen_t len;
+ fd_set fdset;
+ retry_select:
+ FD_ZERO (&fdset);
+ FD_SET (s, &fdset);
+ QUIT;
+ sc = pselect (s + 1, NULL, &fdset, NULL, NULL, NULL);
+ if (sc == -1)
+ {
+ if (errno == EINTR)
+ goto retry_select;
+ else
+ report_file_error ("Failed select", Qnil);
+ }
+ eassert (sc > 0);
+
+ len = sizeof xerrno;
+ eassert (FD_ISSET (s, &fdset));
+ if (getsockopt (s, SOL_SOCKET, SO_ERROR, &xerrno, &len) < 0)
+ report_file_error ("Failed getsockopt", Qnil);
+ if (xerrno == 0)
+ break;
+ if (NILP (addrinfos))
+ report_file_errno ("Failed connect", Qnil, xerrno);
+ }
+#endif /* !WINDOWSNT */
+
+ immediate_quit = 0;
+
+ /* Discard the unwind protect closing S. */
+ specpdl_ptr = specpdl + count;
+ emacs_close (s);
+ s = -1;
+ if (0 <= socket_to_use)
+ break;
+
+#ifdef WINDOWSNT
+ if (xerrno == EINTR)
+ goto retry_connect;
+#endif
+ }
+
+ if (s >= 0)
+ {
+#ifdef DATAGRAM_SOCKETS
+ if (p->socktype == SOCK_DGRAM)
+ {
+ if (datagram_address[s].sa)
+ emacs_abort ();
+
+ datagram_address[s].sa = xmalloc (addrlen);
+ datagram_address[s].len = addrlen;
+ if (p->is_server)
+ {
+ Lisp_Object remote;
+ memset (datagram_address[s].sa, 0, addrlen);
+ if (remote = Fplist_get (contact, QCremote), !NILP (remote))
+ {
+ int rfamily;
+ ptrdiff_t rlen = get_lisp_to_sockaddr_size (remote, &rfamily);
+ if (rlen != 0 && rfamily == family
+ && rlen == addrlen)
+ conv_lisp_to_sockaddr (rfamily, remote,
+ datagram_address[s].sa, rlen);
+ }
+ }
+ else
+ memcpy (datagram_address[s].sa, sa, addrlen);
+ }
+#endif
+
+ contact = Fplist_put (contact, p->is_server? QClocal: QCremote,
+ conv_sockaddr_to_lisp (sa, addrlen));
+#ifdef HAVE_GETSOCKNAME
+ if (!p->is_server)
+ {
+ struct sockaddr_in sa1;
+ socklen_t len1 = sizeof (sa1);
+ if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0)
+ contact = Fplist_put (contact, QClocal,
+ conv_sockaddr_to_lisp ((struct sockaddr *)&sa1, len1));
+ }
+#endif
+ }
+
+ immediate_quit = 0;
+
+ if (s < 0)
+ {
+ /* If non-blocking got this far - and failed - assume non-blocking is
+ not supported after all. This is probably a wrong assumption, but
+ the normal blocking calls to open-network-stream handles this error
+ better. */
+ if (p->is_non_blocking_client)
+ return;
+
+ report_file_errno ((p->is_server
+ ? "make server process failed"
+ : "make client process failed"),
+ contact, xerrno);
+ }
+
+ inch = s;
+ outch = s;
+
+ chan_process[inch] = proc;
+
+ fcntl (inch, F_SETFL, O_NONBLOCK);
+
+ p = XPROCESS (proc);
+ p->open_fd[SUBPROCESS_STDIN] = inch;
+ p->infd = inch;
+ p->outfd = outch;
+
+ /* Discard the unwind protect for closing S, if any. */
+ specpdl_ptr = specpdl + count;
+
+ if (p->is_server && p->socktype != SOCK_DGRAM)
+ pset_status (p, Qlisten);
+
+ /* Make the process marker point into the process buffer (if any). */
+ if (BUFFERP (p->buffer))
+ set_marker_both (p->mark, p->buffer,
+ BUF_ZV (XBUFFER (p->buffer)),
+ BUF_ZV_BYTE (XBUFFER (p->buffer)));
+
+ if (p->is_non_blocking_client)
+ {
+ /* We may get here if connect did succeed immediately. However,
+ in that case, we still need to signal this like a non-blocking
+ connection. */
+ if (! (connecting_status (p->status)
+ && EQ (XCDR (p->status), addrinfos)))
+ pset_status (p, Fcons (Qconnect, addrinfos));
- if (!FD_ISSET (inch, &connect_wait_mask))
- {
- FD_SET (inch, &connect_wait_mask);
- FD_SET (inch, &write_mask);
- num_pending_connects++;
- }
++ if ((fd_callback_info[inch].flags & NON_BLOCKING_CONNECT_FD) == 0)
++ add_non_blocking_write_fd (inch);
+ }
+ else
+ /* A server may have a client filter setting of Qt, but it must
+ still listen for incoming connects unless it is stopped. */
+ if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt))
+ || (EQ (p->status, Qlisten) && NILP (p->command)))
- {
- FD_SET (inch, &input_wait_mask);
- FD_SET (inch, &non_keyboard_wait_mask);
- }
++ add_non_keyboard_read_fd (inch);
+
- if (inch > max_process_desc)
- max_process_desc = inch;
++ if (inch > max_desc)
++ max_desc = inch;
+
+ /* Set up the masks based on the process filter. */
+ set_process_filter_masks (p);
+
+ setup_process_coding_systems (proc);
+
+#ifdef HAVE_GNUTLS
+ /* Continue the asynchronous connection. */
+ if (!NILP (p->gnutls_boot_parameters))
+ {
+ Lisp_Object boot, params = p->gnutls_boot_parameters;
+
+ boot = Fgnutls_boot (proc, XCAR (params), XCDR (params));
+ p->gnutls_boot_parameters = Qnil;
+
+ if (p->gnutls_initstage == GNUTLS_STAGE_READY)
+ /* Run sentinels, etc. */
+ finish_after_tls_connection (proc);
+ else if (p->gnutls_initstage != GNUTLS_STAGE_HANDSHAKE_TRIED)
+ {
+ deactivate_process (proc);
+ if (NILP (boot))
+ pset_status (p, list2 (Qfailed,
+ build_string ("TLS negotiation failed")));
+ else
+ pset_status (p, list2 (Qfailed, boot));
+ }
+ }
+#endif
+
+}
+
+/* Create a network stream/datagram client/server process. Treated
+ exactly like a normal process when reading and writing. Primary
+ differences are in status display and process deletion. A network
+ connection has no PID; you cannot signal it. All you can do is
+ stop/continue it and deactivate/close it via delete-process. */
+
+DEFUN ("make-network-process", Fmake_network_process, Smake_network_process,
+ 0, MANY, 0,
+ doc: /* Create and return a network server or client process.
+
+In Emacs, network connections are represented by process objects, so
+input and output work as for subprocesses and `delete-process' closes
+a network connection. However, a network process has no process id,
+it cannot be signaled, and the status codes are different from normal
+processes.
+
+Arguments are specified as keyword/argument pairs. The following
+arguments are defined:
+
+:name NAME -- NAME is name for process. It is modified if necessary
+to make it unique.
+
+:buffer BUFFER -- BUFFER is the buffer (or buffer-name) to associate
+with the process. Process output goes at end of that buffer, unless
+you specify an output stream or filter function to handle the output.
+BUFFER may be also nil, meaning that this process is not associated
+with any buffer.
+
+:host HOST -- HOST is name of the host to connect to, or its IP
+address. The symbol `local' specifies the local host. If specified
+for a server process, it must be a valid name or address for the local
+host, and only clients connecting to that address will be accepted.
+
+:service SERVICE -- SERVICE is name of the service desired, or an
+integer specifying a port number to connect to. If SERVICE is t,
+a random port number is selected for the server. A port number can
+be specified as an integer string, e.g., "80", as well as an integer.
+
+:type TYPE -- TYPE is the type of connection. The default (nil) is a
+stream type connection, `datagram' creates a datagram type connection,
+`seqpacket' creates a reliable datagram connection.
+
+:family FAMILY -- FAMILY is the address (and protocol) family for the
+service specified by HOST and SERVICE. The default (nil) is to use
+whatever address family (IPv4 or IPv6) that is defined for the host
+and port number specified by HOST and SERVICE. Other address families
+supported are:
+ local -- for a local (i.e. UNIX) address specified by SERVICE.
+ ipv4 -- use IPv4 address family only.
+ ipv6 -- use IPv6 address family only.
+
+:local ADDRESS -- ADDRESS is the local address used for the connection.
+This parameter is ignored when opening a client process. When specified
+for a server process, the FAMILY, HOST and SERVICE args are ignored.
+
+:remote ADDRESS -- ADDRESS is the remote partner's address for the
+connection. This parameter is ignored when opening a stream server
+process. For a datagram server process, it specifies the initial
+setting of the remote datagram address. When specified for a client
+process, the FAMILY, HOST, and SERVICE args are ignored.
+
+The format of ADDRESS depends on the address family:
+- An IPv4 address is represented as an vector of integers [A B C D P]
+corresponding to numeric IP address A.B.C.D and port number P.
+- A local address is represented as a string with the address in the
+local address space.
+- An "unsupported family" address is represented by a cons (F . AV)
+where F is the family number and AV is a vector containing the socket
+address data with one element per address data byte. Do not rely on
+this format in portable code, as it may depend on implementation
+defined constants, data sizes, and data structure alignment.
+
+:coding CODING -- If CODING is a symbol, it specifies the coding
+system used for both reading and writing for this process. If CODING
+is a cons (DECODING . ENCODING), DECODING is used for reading, and
+ENCODING is used for writing.
+
+:nowait BOOL -- If NOWAIT is non-nil for a stream type client
+process, return without waiting for the connection to complete;
+instead, the sentinel function will be called with second arg matching
+"open" (if successful) or "failed" when the connect completes.
+Default is to use a blocking connect (i.e. wait) for stream type
+connections.
+
+:noquery BOOL -- Query the user unless BOOL is non-nil, and process is
+running when Emacs is exited.
+
+:stop BOOL -- Start process in the `stopped' state if BOOL non-nil.
+In the stopped state, a server process does not accept new
+connections, and a client process does not handle incoming traffic.
+The stopped state is cleared by `continue-process' and set by
+`stop-process'.
+
+:filter FILTER -- Install FILTER as the process filter.
+
+:filter-multibyte BOOL -- If BOOL is non-nil, strings given to the
+process filter are multibyte, otherwise they are unibyte.
+If this keyword is not specified, the strings are multibyte if
+the default value of `enable-multibyte-characters' is non-nil.
+
+:sentinel SENTINEL -- Install SENTINEL as the process sentinel.
+
+:log LOG -- Install LOG as the server process log function. This
+function is called when the server accepts a network connection from a
+client. The arguments are SERVER, CLIENT, and MESSAGE, where SERVER
+is the server process, CLIENT is the new process for the connection,
and MESSAGE is a string.
:plist PLIST -- Install PLIST as the new process's initial plist.
}
#endif
chan_process[inchannel] = Qnil;
- FD_CLR (inchannel, &input_wait_mask);
- FD_CLR (inchannel, &non_keyboard_wait_mask);
- if (FD_ISSET (inchannel, &connect_wait_mask))
- {
- FD_CLR (inchannel, &connect_wait_mask);
- FD_CLR (inchannel, &write_mask);
- if (--num_pending_connects < 0)
- emacs_abort ();
- }
- if (inchannel == max_process_desc)
- {
- /* We just closed the highest-numbered process input descriptor,
- so recompute the highest-numbered one now. */
- int i = inchannel;
- do
- i--;
- while (0 <= i && NILP (chan_process[i]));
-
- max_process_desc = i;
- }
+ delete_read_fd (inchannel);
-#ifdef NON_BLOCKING_CONNECT
+ if ((fd_callback_info[inchannel].flags & NON_BLOCKING_CONNECT_FD) != 0)
+ delete_write_fd (inchannel);
-#endif
+ if (inchannel == max_desc)
+ recompute_max_desc ();
}
}
exec_sentinel (proc, concat3 (open_from, host_string, nl));
}
- /* This variable is different from waiting_for_input in keyboard.c.
- It is used to communicate to a lisp process-filter/sentinel (via the
- function Fwaiting_for_user_input_p below) whether Emacs was waiting
- for user-input when that process-filter was called.
- waiting_for_input cannot be used as that is by definition 0 when
- lisp code is being evalled.
- This is also used in record_asynch_buffer_change.
- For that purpose, this must be 0
- when not inside wait_reading_process_output. */
- static int waiting_for_user_input_p;
-
+#ifdef HAVE_GETADDRINFO_A
+static Lisp_Object
+check_for_dns (Lisp_Object proc)
+{
+ struct Lisp_Process *p = XPROCESS (proc);
+ Lisp_Object addrinfos = Qnil;
+
+ /* Sanity check. */
+ if (! p->dns_request)
+ return Qnil;
+
+ int ret = gai_error (p->dns_request);
+ if (ret == EAI_INPROGRESS)
+ return Qt;
+
+ /* We got a response. */
+ if (ret == 0)
+ {
+ struct addrinfo *res;
+
+ for (res = p->dns_request->ar_result; res; res = res->ai_next)
+ addrinfos = Fcons (conv_addrinfo_to_lisp (res), addrinfos);
+
+ addrinfos = Fnreverse (addrinfos);
+ }
+ /* The DNS lookup failed. */
+ else if (connecting_status (p->status))
+ {
+ deactivate_process (proc);
+ pset_status (p, (list2
+ (Qfailed,
+ concat3 (build_string ("Name lookup of "),
+ build_string (p->dns_request->ar_name),
+ build_string (" failed")))));
+ }
+
+ free_dns_request (proc);
+
+ /* This process should not already be connected (or killed). */
+ if (! connecting_status (p->status))
+ return Qnil;
+
+ return addrinfos;
+}
+
+#endif /* HAVE_GETADDRINFO_A */
+
+static void
+wait_for_socket_fds (Lisp_Object process, char const *name)
+{
+ while (XPROCESS (process)->infd < 0
+ && connecting_status (XPROCESS (process)->status))
+ {
+ add_to_log ("Waiting for socket from %s...", build_string (name));
+ wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0);
+ }
+}
+
+static void
+wait_while_connecting (Lisp_Object process)
+{
+ while (connecting_status (XPROCESS (process)->status))
+ {
+ add_to_log ("Waiting for connection...");
+ wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0);
+ }
+}
+
+static void
+wait_for_tls_negotiation (Lisp_Object process)
+{
+#ifdef HAVE_GNUTLS
+ while (XPROCESS (process)->gnutls_p
+ && XPROCESS (process)->gnutls_initstage != GNUTLS_STAGE_READY)
+ {
+ add_to_log ("Waiting for TLS...");
+ wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0);
+ }
+#endif
+}
+
static void
wait_reading_process_output_unwind (int data)
{
if (kbd_on_hold_p ())
FD_ZERO (&Atemp);
else
- Atemp = input_wait_mask;
- Ctemp = write_mask;
+ compute_input_wait_mask (&Atemp);
+ compute_write_mask (&Ctemp);
timeout = make_timespec (0, 0);
- if ((pselect (max (max_process_desc, max_input_desc) + 1,
- &Atemp,
- (num_pending_connects > 0 ? &Ctemp : NULL),
- NULL, &timeout, NULL)
+ if ((thread_select (pselect, max_desc + 1,
+ &Atemp,
-#ifdef NON_BLOCKING_CONNECT
+ (num_pending_connects > 0 ? &Ctemp : NULL),
-#else
- NULL,
-#endif
+ NULL, &timeout, NULL)
<= 0))
{
/* It's okay for us to do this and then continue with
if (timeout.tv_sec > 0 || timeout.tv_nsec > 0)
now = invalid_timespec ();
+#if defined HAVE_GETADDRINFO_A || defined HAVE_GNUTLS
+ if (retry_for_async
+ && (timeout.tv_sec > 0 || timeout.tv_nsec > ASYNC_RETRY_NSEC))
+ {
+ timeout.tv_sec = 0;
+ timeout.tv_nsec = ASYNC_RETRY_NSEC;
+ }
+#endif
+
+ nfds = thread_select (
#if defined (HAVE_NS)
- nfds = ns_select
+ ns_select
#elif defined (HAVE_GLIB)
- nfds = xg_select
+ xg_select
#else
- nfds = pselect
+ pselect
#endif
- (max (max_process_desc, max_input_desc) + 1,
- &Available,
- (check_write ? &Writeok : 0),
- NULL, &timeout, NULL);
+ , max_desc + 1,
+ &Available,
+ (check_write ? &Writeok : 0),
+ NULL, &timeout, NULL);
#ifdef HAVE_GNUTLS
/* GnuTLS buffers data internally. In lowat mode it leaves
list2 (Qexit, make_number (256)));
}
}
-#ifdef NON_BLOCKING_CONNECT
if (FD_ISSET (channel, &Writeok)
- && FD_ISSET (channel, &connect_wait_mask))
+ && (fd_callback_info[channel].flags
+ & NON_BLOCKING_CONNECT_FD) != 0)
{
struct Lisp_Process *p;
}
else
{
- pset_status (p, Qrun);
- /* Execute the sentinel here. If we had relied on
- status_notify to do it later, it will read input
- from the process before calling the sentinel. */
- exec_sentinel (proc, build_string ("open\n"));
+#ifdef HAVE_GNUTLS
+ /* If we have an incompletely set up TLS connection,
+ then defer the sentinel signaling until
+ later. */
+ if (NILP (p->gnutls_boot_parameters)
+ && !p->gnutls_p)
+#endif
+ {
+ pset_status (p, Qrun);
+ /* Execute the sentinel here. If we had relied on
+ status_notify to do it later, it will read input
+ from the process before calling the sentinel. */
+ exec_sentinel (proc, build_string ("open\n"));
+ }
+
if (0 <= p->infd && !EQ (p->filter, Qt)
&& !EQ (p->command, Qt))
- {
- FD_SET (p->infd, &input_wait_mask);
- FD_SET (p->infd, &non_keyboard_wait_mask);
- }
+ delete_read_fd (p->infd);
}
}
-#endif /* NON_BLOCKING_CONNECT */
} /* End for each file descriptor. */
} /* End while exit conditions not met. */
catch_child_signal ();
}
- FD_ZERO (&input_wait_mask);
- FD_ZERO (&non_keyboard_wait_mask);
- FD_ZERO (&non_process_wait_mask);
- FD_ZERO (&write_mask);
- max_process_desc = max_input_desc = -1;
+#ifdef HAVE_SETRLIMIT
+ /* Don't allocate more than FD_SETSIZE file descriptors for Emacs itself. */
+ if (getrlimit (RLIMIT_NOFILE, &nofile_limit) != 0)
+ nofile_limit.rlim_cur = 0;
+ else if (FD_SETSIZE < nofile_limit.rlim_cur)
+ {
+ struct rlimit rlim = nofile_limit;
+ rlim.rlim_cur = FD_SETSIZE;
+ if (setrlimit (RLIMIT_NOFILE, &rlim) != 0)
+ nofile_limit.rlim_cur = 0;
+ }
+#endif
+
+ external_sock_fd = sockfd;
+ max_desc = -1;
memset (fd_callback_info, 0, sizeof (fd_callback_info));
- FD_ZERO (&connect_wait_mask);
-#ifdef NON_BLOCKING_CONNECT
num_pending_connects = 0;
-#endif
process_output_delay_count = 0;
process_output_skip = 0;
#endif /* not DEBUG */
\f
-/* Use this to suppress gcc's `...may be used before initialized' warnings. */
-#ifdef lint
-# define IF_LINT(Code) Code
-#else
-# define IF_LINT(Code) /* empty */
-#endif
-\f
#ifndef emacs
-
/* Set by `re_set_syntax' to the current regexp syntax to recognize. Can
also be assigned to arbitrarily: each pattern buffer stores its own
syntax, so it can be changed between regex compilations. */
}
WEAK_ALIAS (__re_set_syntax, re_set_syntax)
+ #ifndef emacs
+ /* Regexp to use to replace spaces, or NULL meaning don't. */
+ static const_re_char *whitespace_regexp;
++#else
++/* whitespace_regexp is a macro defined in thread.h. */
#endif
+
+ void
+ re_set_whitespace_regexp (const char *regexp)
+ {
+ whitespace_regexp = (const_re_char *) regexp;
+ }
+ WEAK_ALIAS (__re_set_syntax, re_set_syntax)
++>>>>>>> concurrency
\f
/* This table gives an error message for each of the error codes listed
in regex.h. Obviously the order here has to be same as there.
#ifdef emacs
# include "lisp.h"
-/* In Emacs, this is the string or buffer in which we
- are matching. It is used for looking up syntax properties. */
+/* In Emacs, this is the string or buffer in which we are matching.
+ It is used for looking up syntax properties.
+
+ If the value is a Lisp string object, we are matching text in that
+ string; if it's nil, we are matching text in the current buffer; if
- it's t, we are matching text in a C string. */
- extern Lisp_Object re_match_object;
++ it's t, we are matching text in a C string.
++
++ This is defined as a macro in thread.h, which see. */
+ /* extern Lisp_Object re_match_object; */
#endif
/* Roughly the maximum number of failure points on the stack. */
--- /dev/null
- struct handler *c;
+ /* Threading code.
+ Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+
+ This file is part of GNU Emacs.
+
+ GNU Emacs is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ GNU Emacs is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+
+ #include <config.h>
+ #include <setjmp.h>
+ #include "lisp.h"
+ #include "character.h"
+ #include "buffer.h"
+ #include "process.h"
+ #include "coding.h"
+
+ static struct thread_state primary_thread;
+
+ struct thread_state *current_thread = &primary_thread;
+
+ static struct thread_state *all_threads = &primary_thread;
+
+ static sys_mutex_t global_lock;
+
+ extern int poll_suppress_count;
+ extern volatile int interrupt_input_blocked;
+
+ \f
+
+ /* m_specpdl is set when the thread is created and cleared when the
+ thread dies. */
+ #define thread_alive_p(STATE) ((STATE)->m_specpdl != NULL)
+
+ \f
+
+ static void
+ release_global_lock (void)
+ {
+ sys_mutex_unlock (&global_lock);
+ }
+
+ /* You must call this after acquiring the global lock.
+ acquire_global_lock does it for you. */
+ static void
+ post_acquire_global_lock (struct thread_state *self)
+ {
+ Lisp_Object buffer;
+ struct thread_state *prev_thread = current_thread;
+
+ /* Do this early on, so that code below could signal errors (e.g.,
+ unbind_for_thread_switch might) correctly, because we are already
+ running in the context of the thread pointed by SELF. */
+ current_thread = self;
+
+ if (prev_thread != current_thread)
+ {
+ /* PREV_THREAD is NULL if the previously current thread
+ exited. In this case, there is no reason to unbind, and
+ trying will crash. */
+ if (prev_thread != NULL)
+ unbind_for_thread_switch (prev_thread);
+ rebind_for_thread_switch ();
+ }
+
+ /* We need special handling to re-set the buffer. */
+ XSETBUFFER (buffer, self->m_current_buffer);
+ self->m_current_buffer = 0;
+ set_buffer_internal (XBUFFER (buffer));
+
+ if (!NILP (current_thread->error_symbol))
+ {
+ Lisp_Object sym = current_thread->error_symbol;
+ Lisp_Object data = current_thread->error_data;
+
+ current_thread->error_symbol = Qnil;
+ current_thread->error_data = Qnil;
+ Fsignal (sym, data);
+ }
+ }
+
+ static void
+ acquire_global_lock (struct thread_state *self)
+ {
+ sys_mutex_lock (&global_lock);
+ post_acquire_global_lock (self);
+ }
+
+ \f
+
+ static void
+ lisp_mutex_init (lisp_mutex_t *mutex)
+ {
+ mutex->owner = NULL;
+ mutex->count = 0;
+ sys_cond_init (&mutex->condition);
+ }
+
+ static int
+ lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
+ {
+ struct thread_state *self;
+
+ if (mutex->owner == NULL)
+ {
+ mutex->owner = current_thread;
+ mutex->count = new_count == 0 ? 1 : new_count;
+ return 0;
+ }
+ if (mutex->owner == current_thread)
+ {
+ eassert (new_count == 0);
+ ++mutex->count;
+ return 0;
+ }
+
+ self = current_thread;
+ self->wait_condvar = &mutex->condition;
+ while (mutex->owner != NULL && (new_count != 0
+ || NILP (self->error_symbol)))
+ sys_cond_wait (&mutex->condition, &global_lock);
+ self->wait_condvar = NULL;
+
+ if (new_count == 0 && !NILP (self->error_symbol))
+ return 1;
+
+ mutex->owner = self;
+ mutex->count = new_count == 0 ? 1 : new_count;
+
+ return 1;
+ }
+
+ static int
+ lisp_mutex_unlock (lisp_mutex_t *mutex)
+ {
+ struct thread_state *self = current_thread;
+
+ if (mutex->owner != current_thread)
+ error ("blah");
+
+ if (--mutex->count > 0)
+ return 0;
+
+ mutex->owner = NULL;
+ sys_cond_broadcast (&mutex->condition);
+
+ return 1;
+ }
+
+ static unsigned int
+ lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex)
+ {
+ struct thread_state *self = current_thread;
+ unsigned int result = mutex->count;
+
+ /* Ensured by condvar code. */
+ eassert (mutex->owner == current_thread);
+
+ mutex->count = 0;
+ mutex->owner = NULL;
+ sys_cond_broadcast (&mutex->condition);
+
+ return result;
+ }
+
+ static void
+ lisp_mutex_destroy (lisp_mutex_t *mutex)
+ {
+ sys_cond_destroy (&mutex->condition);
+ }
+
+ static int
+ lisp_mutex_owned_p (lisp_mutex_t *mutex)
+ {
+ return mutex->owner == current_thread;
+ }
+
+ \f
+
+ DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0,
+ doc: /* Create a mutex.
+ A mutex provides a synchronization point for threads.
+ Only one thread at a time can hold a mutex. Other threads attempting
+ to acquire it will block until the mutex is available.
+
+ A thread can acquire a mutex any number of times.
+
+ NAME, if given, is used as the name of the mutex. The name is
+ informational only. */)
+ (Lisp_Object name)
+ {
+ struct Lisp_Mutex *mutex;
+ Lisp_Object result;
+
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
+ memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
+ 0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
+ mutex));
+ mutex->name = name;
+ lisp_mutex_init (&mutex->mutex);
+
+ XSETMUTEX (result, mutex);
+ return result;
+ }
+
+ static void
+ mutex_lock_callback (void *arg)
+ {
+ struct Lisp_Mutex *mutex = arg;
+ struct thread_state *self = current_thread;
+
+ if (lisp_mutex_lock (&mutex->mutex, 0))
+ post_acquire_global_lock (self);
+ }
+
+ static void
+ do_unwind_mutex_lock (void)
+ {
+ current_thread->event_object = Qnil;
+ }
+
+ DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
+ doc: /* Acquire a mutex.
+ If the current thread already owns MUTEX, increment the count and
+ return.
+ Otherwise, if no thread owns MUTEX, make the current thread own it.
+ Otherwise, block until MUTEX is available, or until the current thread
+ is signalled using `thread-signal'.
+ Note that calls to `mutex-lock' and `mutex-unlock' must be paired. */)
+ (Lisp_Object mutex)
+ {
+ struct Lisp_Mutex *lmutex;
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ current_thread->event_object = mutex;
+ record_unwind_protect_void (do_unwind_mutex_lock);
+ flush_stack_call_func (mutex_lock_callback, lmutex);
+ return unbind_to (count, Qnil);
+ }
+
+ static void
+ mutex_unlock_callback (void *arg)
+ {
+ struct Lisp_Mutex *mutex = arg;
+ struct thread_state *self = current_thread;
+
+ if (lisp_mutex_unlock (&mutex->mutex))
+ post_acquire_global_lock (self);
+ }
+
+ DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
+ doc: /* Release the mutex.
+ If this thread does not own MUTEX, signal an error.
+ Otherwise, decrement the mutex's count. If the count is zero,
+ release MUTEX. */)
+ (Lisp_Object mutex)
+ {
+ struct Lisp_Mutex *lmutex;
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ flush_stack_call_func (mutex_unlock_callback, lmutex);
+ return Qnil;
+ }
+
+ DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0,
+ doc: /* Return the name of MUTEX.
+ If no name was given when MUTEX was created, return nil. */)
+ (Lisp_Object mutex)
+ {
+ struct Lisp_Mutex *lmutex;
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ return lmutex->name;
+ }
+
+ void
+ finalize_one_mutex (struct Lisp_Mutex *mutex)
+ {
+ lisp_mutex_destroy (&mutex->mutex);
+ }
+
+ \f
+
+ DEFUN ("make-condition-variable",
+ Fmake_condition_variable, Smake_condition_variable,
+ 1, 2, 0,
+ doc: /* Make a condition variable.
+ A condition variable provides a way for a thread to sleep while
+ waiting for a state change.
+
+ MUTEX is the mutex associated with this condition variable.
+ NAME, if given, is the name of this condition variable. The name is
+ informational only. */)
+ (Lisp_Object mutex, Lisp_Object name)
+ {
+ struct Lisp_CondVar *condvar;
+ Lisp_Object result;
+
+ CHECK_MUTEX (mutex);
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR);
+ memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond),
+ 0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar,
+ cond));
+ condvar->mutex = mutex;
+ condvar->name = name;
+ sys_cond_init (&condvar->cond);
+
+ XSETCONDVAR (result, condvar);
+ return result;
+ }
+
+ static void
+ condition_wait_callback (void *arg)
+ {
+ struct Lisp_CondVar *cvar = arg;
+ struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex);
+ struct thread_state *self = current_thread;
+ unsigned int saved_count;
+ Lisp_Object cond;
+
+ XSETCONDVAR (cond, cvar);
+ self->event_object = cond;
+ saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
+ /* If we were signalled while unlocking, we skip the wait, but we
+ still must reacquire our lock. */
+ if (NILP (self->error_symbol))
+ {
+ self->wait_condvar = &cvar->cond;
+ sys_cond_wait (&cvar->cond, &global_lock);
+ self->wait_condvar = NULL;
+ }
+ lisp_mutex_lock (&mutex->mutex, saved_count);
+ self->event_object = Qnil;
+ post_acquire_global_lock (self);
+ }
+
+ DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0,
+ doc: /* Wait for the condition variable to be notified.
+ CONDITION is the condition variable to wait on.
+
+ The mutex associated with CONDITION must be held when this is called.
+ It is an error if it is not held.
+
+ This releases the mutex and waits for CONDITION to be notified or for
+ this thread to be signalled with `thread-signal'. When
+ `condition-wait' returns, the mutex will again be locked by this
+ thread. */)
+ (Lisp_Object condition)
+ {
+ struct Lisp_CondVar *cvar;
+ struct Lisp_Mutex *mutex;
+
+ CHECK_CONDVAR (condition);
+ cvar = XCONDVAR (condition);
+
+ mutex = XMUTEX (cvar->mutex);
+ if (!lisp_mutex_owned_p (&mutex->mutex))
+ error ("fixme");
+
+ flush_stack_call_func (condition_wait_callback, cvar);
+
+ return Qnil;
+ }
+
+ /* Used to communicate argumnets to condition_notify_callback. */
+ struct notify_args
+ {
+ struct Lisp_CondVar *cvar;
+ int all;
+ };
+
+ static void
+ condition_notify_callback (void *arg)
+ {
+ struct notify_args *na = arg;
+ struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex);
+ struct thread_state *self = current_thread;
+ unsigned int saved_count;
+ Lisp_Object cond;
+
+ XSETCONDVAR (cond, na->cvar);
+ saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
+ if (na->all)
+ sys_cond_broadcast (&na->cvar->cond);
+ else
+ sys_cond_signal (&na->cvar->cond);
+ lisp_mutex_lock (&mutex->mutex, saved_count);
+ post_acquire_global_lock (self);
+ }
+
+ DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0,
+ doc: /* Notify a condition variable.
+ This wakes a thread waiting on CONDITION.
+ If ALL is non-nil, all waiting threads are awoken.
+
+ The mutex associated with CONDITION must be held when this is called.
+ It is an error if it is not held.
+
+ This releases the mutex when notifying CONDITION. When
+ `condition-notify' returns, the mutex will again be locked by this
+ thread. */)
+ (Lisp_Object condition, Lisp_Object all)
+ {
+ struct Lisp_CondVar *cvar;
+ struct Lisp_Mutex *mutex;
+ struct notify_args args;
+
+ CHECK_CONDVAR (condition);
+ cvar = XCONDVAR (condition);
+
+ mutex = XMUTEX (cvar->mutex);
+ if (!lisp_mutex_owned_p (&mutex->mutex))
+ error ("fixme");
+
+ args.cvar = cvar;
+ args.all = !NILP (all);
+ flush_stack_call_func (condition_notify_callback, &args);
+
+ return Qnil;
+ }
+
+ DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0,
+ doc: /* Return the mutex associated with CONDITION. */)
+ (Lisp_Object condition)
+ {
+ struct Lisp_CondVar *cvar;
+
+ CHECK_CONDVAR (condition);
+ cvar = XCONDVAR (condition);
+
+ return cvar->mutex;
+ }
+
+ DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0,
+ doc: /* Return the name of CONDITION.
+ If no name was given when CONDITION was created, return nil. */)
+ (Lisp_Object condition)
+ {
+ struct Lisp_CondVar *cvar;
+
+ CHECK_CONDVAR (condition);
+ cvar = XCONDVAR (condition);
+
+ return cvar->name;
+ }
+
+ void
+ finalize_one_condvar (struct Lisp_CondVar *condvar)
+ {
+ sys_cond_destroy (&condvar->cond);
+ }
+
+ \f
+
+ struct select_args
+ {
+ select_func *func;
+ int max_fds;
+ fd_set *rfds;
+ fd_set *wfds;
+ fd_set *efds;
+ struct timespec *timeout;
+ sigset_t *sigmask;
+ int result;
+ };
+
+ static void
+ really_call_select (void *arg)
+ {
+ struct select_args *sa = arg;
+ struct thread_state *self = current_thread;
+
+ release_global_lock ();
+ sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds,
+ sa->timeout, sa->sigmask);
+ acquire_global_lock (self);
+ }
+
+ int
+ thread_select (select_func *func, int max_fds, fd_set *rfds,
+ fd_set *wfds, fd_set *efds, struct timespec *timeout,
+ sigset_t *sigmask)
+ {
+ struct select_args sa;
+
+ sa.func = func;
+ sa.max_fds = max_fds;
+ sa.rfds = rfds;
+ sa.wfds = wfds;
+ sa.efds = efds;
+ sa.timeout = timeout;
+ sa.sigmask = sigmask;
+ flush_stack_call_func (really_call_select, &sa);
+ return sa.result;
+ }
+
+ \f
+
+ static void
+ mark_one_thread (struct thread_state *thread)
+ {
+ struct handler *handler;
+ Lisp_Object tem;
+
+ mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
+
+ mark_stack (thread->m_stack_bottom, thread->stack_top);
+
+ for (handler = thread->m_handlerlist; handler; handler = handler->next)
+ {
+ mark_object (handler->tag_or_ch);
+ mark_object (handler->val);
+ }
+
+ if (thread->m_current_buffer)
+ {
+ XSETBUFFER (tem, thread->m_current_buffer);
+ mark_object (tem);
+ }
+
+ mark_object (thread->m_last_thing_searched);
+
+ if (thread->m_saved_last_thing_searched)
+ mark_object (thread->m_saved_last_thing_searched);
+ }
+
+ static void
+ mark_threads_callback (void *ignore)
+ {
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ Lisp_Object thread_obj;
+
+ XSETTHREAD (thread_obj, iter);
+ mark_object (thread_obj);
+ mark_one_thread (iter);
+ }
+ }
+
+ void
+ mark_threads (void)
+ {
+ flush_stack_call_func (mark_threads_callback, NULL);
+ }
+
+ void
+ unmark_threads (void)
+ {
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ if (iter->m_byte_stack_list)
+ relocate_byte_stack (iter->m_byte_stack_list);
+ }
+
+ \f
+
+ static void
+ yield_callback (void *ignore)
+ {
+ struct thread_state *self = current_thread;
+
+ release_global_lock ();
+ sys_thread_yield ();
+ acquire_global_lock (self);
+ }
+
+ DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
+ doc: /* Yield the CPU to another thread. */)
+ (void)
+ {
+ flush_stack_call_func (yield_callback, NULL);
+ return Qnil;
+ }
+
+ static Lisp_Object
+ invoke_thread_function (void)
+ {
+ Lisp_Object iter;
+ volatile struct thread_state *self = current_thread;
+
+ int count = SPECPDL_INDEX ();
+
+ Ffuncall (1, ¤t_thread->function);
+ return unbind_to (count, Qnil);
+ }
+
+ static Lisp_Object
+ do_nothing (Lisp_Object whatever)
+ {
+ return whatever;
+ }
+
+ static void *
+ run_thread (void *state)
+ {
+ char stack_pos;
+ struct thread_state *self = state;
+ struct thread_state **iter;
+
+ self->m_stack_bottom = &stack_pos;
+ self->stack_top = &stack_pos;
+ self->thread_id = sys_thread_self ();
+
+ acquire_global_lock (self);
+
+ { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
+ This is important since handlerlist->nextfree holds the freelist
+ which would otherwise leak every time we unwind back to top-level. */
- PUSH_HANDLER (c, Qunbound, CATCHER);
+ handlerlist_sentinel = xzalloc (sizeof (struct handler));
+ handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
++ struct handler *c = push_handler (Qunbound, CATCHER);
+ eassert (c == handlerlist_sentinel);
+ handlerlist_sentinel->nextfree = NULL;
+ handlerlist_sentinel->next = NULL;
+ }
+
+ /* It might be nice to do something with errors here. */
+ internal_condition_case (invoke_thread_function, Qt, do_nothing);
+
+ update_processes_for_thread_death (Fcurrent_thread ());
+
+ xfree (self->m_specpdl - 1);
+ self->m_specpdl = NULL;
+ self->m_specpdl_ptr = NULL;
+ self->m_specpdl_size = 0;
+
+ {
+ struct handler *c, *c_next;
+ for (c = handlerlist_sentinel; c; c = c_next)
+ {
+ c_next = c->nextfree;
+ xfree (c);
+ }
+ }
+
+ current_thread = NULL;
+ sys_cond_broadcast (&self->thread_condvar);
+
+ /* Unlink this thread from the list of all threads. Note that we
+ have to do this very late, after broadcasting our death.
+ Otherwise the GC may decide to reap the thread_state object,
+ leading to crashes. */
+ for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
+ ;
+ *iter = (*iter)->next_thread;
+
+ release_global_lock ();
+
+ return NULL;
+ }
+
+ void
+ finalize_one_thread (struct thread_state *state)
+ {
+ sys_cond_destroy (&state->thread_condvar);
+ }
+
+ DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
+ doc: /* Start a new thread and run FUNCTION in it.
+ When the function exits, the thread dies.
+ If NAME is given, it names the new thread. */)
+ (Lisp_Object function, Lisp_Object name)
+ {
+ sys_thread_t thr;
+ struct thread_state *new_thread;
+ Lisp_Object result;
+ const char *c_name = NULL;
+ size_t offset = offsetof (struct thread_state, m_byte_stack_list);
+
+ /* Can't start a thread in temacs. */
+ if (!initialized)
+ abort ();
+
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_byte_stack_list,
+ PVEC_THREAD);
+ memset ((char *) new_thread + offset, 0,
+ sizeof (struct thread_state) - offset);
+
+ new_thread->function = function;
+ new_thread->name = name;
+ new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
+ new_thread->m_saved_last_thing_searched = Qnil;
+ new_thread->m_current_buffer = current_thread->m_current_buffer;
+ new_thread->error_symbol = Qnil;
+ new_thread->error_data = Qnil;
+ new_thread->event_object = Qnil;
+
+ new_thread->m_specpdl_size = 50;
+ new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
+ * sizeof (union specbinding));
+ /* Skip the dummy entry. */
+ ++new_thread->m_specpdl;
+ new_thread->m_specpdl_ptr = new_thread->m_specpdl;
+
+ sys_cond_init (&new_thread->thread_condvar);
+
+ /* We'll need locking here eventually. */
+ new_thread->next_thread = all_threads;
+ all_threads = new_thread;
+
+ if (!NILP (name))
+ c_name = SSDATA (ENCODE_UTF_8 (name));
+
+ if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
+ {
+ /* Restore the previous situation. */
+ all_threads = all_threads->next_thread;
+ error ("Could not start a new thread");
+ }
+
+ /* FIXME: race here where new thread might not be filled in? */
+ XSETTHREAD (result, new_thread);
+ return result;
+ }
+
+ DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
+ doc: /* Return the current thread. */)
+ (void)
+ {
+ Lisp_Object result;
+ XSETTHREAD (result, current_thread);
+ return result;
+ }
+
+ DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
+ doc: /* Return the name of the THREAD.
+ The name is the same object that was passed to `make-thread'. */)
+ (Lisp_Object thread)
+ {
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return tstate->name;
+ }
+
+ static void
+ thread_signal_callback (void *arg)
+ {
+ struct thread_state *tstate = arg;
+ struct thread_state *self = current_thread;
+
+ sys_cond_broadcast (tstate->wait_condvar);
+ post_acquire_global_lock (self);
+ }
+
+ DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
+ doc: /* Signal an error in a thread.
+ This acts like `signal', but arranges for the signal to be raised
+ in THREAD. If THREAD is the current thread, acts just like `signal'.
+ This will interrupt a blocked call to `mutex-lock', `condition-wait',
+ or `thread-join' in the target thread. */)
+ (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
+ {
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ if (tstate == current_thread)
+ Fsignal (error_symbol, data);
+
+ /* What to do if thread is already signalled? */
+ /* What if error_symbol is Qnil? */
+ tstate->error_symbol = error_symbol;
+ tstate->error_data = data;
+
+ if (tstate->wait_condvar)
+ flush_stack_call_func (thread_signal_callback, tstate);
+
+ return Qnil;
+ }
+
+ DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
+ doc: /* Return t if THREAD is alive, or nil if it has exited. */)
+ (Lisp_Object thread)
+ {
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return thread_alive_p (tstate) ? Qt : Qnil;
+ }
+
+ DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
+ doc: /* Return the object that THREAD is blocking on.
+ If THREAD is blocked in `thread-join' on a second thread, return that
+ thread.
+ If THREAD is blocked in `mutex-lock', return the mutex.
+ If THREAD is blocked in `condition-wait', return the condition variable.
+ Otherwise, if THREAD is not blocked, return nil. */)
+ (Lisp_Object thread)
+ {
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return tstate->event_object;
+ }
+
+ static void
+ thread_join_callback (void *arg)
+ {
+ struct thread_state *tstate = arg;
+ struct thread_state *self = current_thread;
+ Lisp_Object thread;
+
+ XSETTHREAD (thread, tstate);
+ self->event_object = thread;
+ self->wait_condvar = &tstate->thread_condvar;
+ while (thread_alive_p (tstate) && NILP (self->error_symbol))
+ sys_cond_wait (self->wait_condvar, &global_lock);
+
+ self->wait_condvar = NULL;
+ self->event_object = Qnil;
+ post_acquire_global_lock (self);
+ }
+
+ DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
+ doc: /* Wait for a thread to exit.
+ This blocks the current thread until THREAD exits.
+ It is an error for a thread to try to join itself. */)
+ (Lisp_Object thread)
+ {
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ if (tstate == current_thread)
+ error ("cannot join current thread");
+
+ if (thread_alive_p (tstate))
+ flush_stack_call_func (thread_join_callback, tstate);
+
+ return Qnil;
+ }
+
+ DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
+ doc: /* Return a list of all threads. */)
+ (void)
+ {
+ Lisp_Object result = Qnil;
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ if (thread_alive_p (iter))
+ {
+ Lisp_Object thread;
+
+ XSETTHREAD (thread, iter);
+ result = Fcons (thread, result);
+ }
+ }
+
+ return result;
+ }
+
+ \f
+
+ bool
+ thread_check_current_buffer (struct buffer *buffer)
+ {
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ if (iter == current_thread)
+ continue;
+
+ if (iter->m_current_buffer == buffer)
+ return true;
+ }
+
+ return false;
+ }
+
+ \f
+
+ static void
+ init_primary_thread (void)
+ {
+ primary_thread.header.size
+ = PSEUDOVECSIZE (struct thread_state, m_byte_stack_list);
+ XSETPVECTYPE (&primary_thread, PVEC_THREAD);
+ primary_thread.m_last_thing_searched = Qnil;
+ primary_thread.m_saved_last_thing_searched = Qnil;
+ primary_thread.name = Qnil;
+ primary_thread.function = Qnil;
+ primary_thread.error_symbol = Qnil;
+ primary_thread.error_data = Qnil;
+ primary_thread.event_object = Qnil;
+ }
+
+ void
+ init_threads_once (void)
+ {
+ init_primary_thread ();
+ }
+
+ void
+ init_threads (void)
+ {
+ init_primary_thread ();
+ sys_cond_init (&primary_thread.thread_condvar);
+ sys_mutex_init (&global_lock);
+ sys_mutex_lock (&global_lock);
+ current_thread = &primary_thread;
+ primary_thread.thread_id = sys_thread_self ();
+ }
+
+ void
+ syms_of_threads (void)
+ {
+ #ifndef THREADS_ENABLED
+ if (0)
+ #endif
+ {
+ defsubr (&Sthread_yield);
+ defsubr (&Smake_thread);
+ defsubr (&Scurrent_thread);
+ defsubr (&Sthread_name);
+ defsubr (&Sthread_signal);
+ defsubr (&Sthread_alive_p);
+ defsubr (&Sthread_join);
+ defsubr (&Sthread_blocker);
+ defsubr (&Sall_threads);
+ defsubr (&Smake_mutex);
+ defsubr (&Smutex_lock);
+ defsubr (&Smutex_unlock);
+ defsubr (&Smutex_name);
+ defsubr (&Smake_condition_variable);
+ defsubr (&Scondition_wait);
+ defsubr (&Scondition_notify);
+ defsubr (&Scondition_mutex);
+ defsubr (&Scondition_name);
+ }
+
+ DEFSYM (Qthreadp, "threadp");
+ DEFSYM (Qmutexp, "mutexp");
+ DEFSYM (Qcondition_variable_p, "condition-variable-p");
+ }
--- /dev/null
- are matching. It is used for looking up syntax properties. */
+ /* Thread definitions
+ Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+
+ This file is part of GNU Emacs.
+
+ GNU Emacs is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ GNU Emacs is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+ #ifndef THREAD_H
+ #define THREAD_H
+
+ #include "regex.h"
+
+ #ifdef WINDOWSNT
+ #include <sys/socket.h>
+ #endif
+
+ #include "sysselect.h" /* FIXME */
+ #include "systime.h" /* FIXME */
+
+ struct thread_state
+ {
+ struct vectorlike_header header;
+
+ /* The buffer in which the last search was performed, or
+ Qt if the last search was done in a string;
+ Qnil if no searching has been done yet. */
+ Lisp_Object m_last_thing_searched;
+ #define last_thing_searched (current_thread->m_last_thing_searched)
+
+ Lisp_Object m_saved_last_thing_searched;
+ #define saved_last_thing_searched (current_thread->m_saved_last_thing_searched)
+
+ /* The thread's name. */
+ Lisp_Object name;
+
+ /* The thread's function. */
+ Lisp_Object function;
+
+ /* If non-nil, this thread has been signalled. */
+ Lisp_Object error_symbol;
+ Lisp_Object error_data;
+
+ /* If we are waiting for some event, this holds the object we are
+ waiting on. */
+ Lisp_Object event_object;
+
+ /* m_byte_stack_list must be the first non-lisp field. */
+ /* A list of currently active byte-code execution value stacks.
+ Fbyte_code adds an entry to the head of this list before it starts
+ processing byte-code, and it removed the entry again when it is
+ done. Signalling an error truncates the list. */
+ struct byte_stack *m_byte_stack_list;
+ #define byte_stack_list (current_thread->m_byte_stack_list)
+
+ /* An address near the bottom of the stack.
+ Tells GC how to save a copy of the stack. */
+ char *m_stack_bottom;
+ #define stack_bottom (current_thread->m_stack_bottom)
+
+ /* An address near the top of the stack. */
+ char *stack_top;
+
+ struct catchtag *m_catchlist;
+ #define catchlist (current_thread->m_catchlist)
+
+ /* Chain of condition handlers currently in effect.
+ The elements of this chain are contained in the stack frames
+ of Fcondition_case and internal_condition_case.
+ When an error is signaled (by calling Fsignal, below),
+ this chain is searched for an element that applies. */
+ struct handler *m_handlerlist;
+ #define handlerlist (current_thread->m_handlerlist)
+
+ struct handler *m_handlerlist_sentinel;
+ #define handlerlist_sentinel (current_thread->m_handlerlist_sentinel)
+
+ /* Current number of specbindings allocated in specpdl. */
+ ptrdiff_t m_specpdl_size;
+ #define specpdl_size (current_thread->m_specpdl_size)
+
+ /* Pointer to beginning of specpdl. */
+ union specbinding *m_specpdl;
+ #define specpdl (current_thread->m_specpdl)
+
+ /* Pointer to first unused element in specpdl. */
+ union specbinding *m_specpdl_ptr;
+ #define specpdl_ptr (current_thread->m_specpdl_ptr)
+
+ /* Depth in Lisp evaluations and function calls. */
+ EMACS_INT m_lisp_eval_depth;
+ #define lisp_eval_depth (current_thread->m_lisp_eval_depth)
+
+ /* This points to the current buffer. */
+ struct buffer *m_current_buffer;
+ #define current_buffer (current_thread->m_current_buffer)
+
+ /* Every call to re_match, etc., must pass &search_regs as the regs
+ argument unless you can show it is unnecessary (i.e., if re_match
+ is certainly going to be called again before region-around-match
+ can be called).
+
+ Since the registers are now dynamically allocated, we need to make
+ sure not to refer to the Nth register before checking that it has
+ been allocated by checking search_regs.num_regs.
+
+ The regex code keeps track of whether it has allocated the search
+ buffer using bits in the re_pattern_buffer. This means that whenever
+ you compile a new pattern, it completely forgets whether it has
+ allocated any registers, and will allocate new registers the next
+ time you call a searching or matching function. Therefore, we need
+ to call re_set_registers after compiling a new pattern or after
+ setting the match registers, so that the regex functions will be
+ able to free or re-allocate it properly. */
+ struct re_registers m_search_regs;
+ #define search_regs (current_thread->m_search_regs)
+
+ /* If non-zero the match data have been saved in saved_search_regs
+ during the execution of a sentinel or filter. */
+ bool m_search_regs_saved;
+ #define search_regs_saved (current_thread->m_search_regs_saved)
+
+ struct re_registers m_saved_search_regs;
+ #define saved_search_regs (current_thread->m_saved_search_regs)
+
+ /* This is the string or buffer in which we
++ are matching. It is used for looking up syntax properties.
++
++ If the value is a Lisp string object, we are matching text in that
++ string; if it's nil, we are matching text in the current buffer; if
++ it's t, we are matching text in a C string. */
+ Lisp_Object m_re_match_object;
+ #define re_match_object (current_thread->m_re_match_object)
+
+ /* Set by `re_set_syntax' to the current regexp syntax to recognize. Can
+ also be assigned to arbitrarily: each pattern buffer stores its own
+ syntax, so it can be changed between regex compilations. */
+ reg_syntax_t m_re_syntax_options;
+ #define re_syntax_options (current_thread->m_re_syntax_options)
+
+ /* Regexp to use to replace spaces, or NULL meaning don't. */
+ /* This ought to be a "const re_char *" but that is not available
+ outside regex.h. */
+ const void *m_whitespace_regexp;
+ #define whitespace_regexp (current_thread->m_whitespace_regexp)
+
+ /* This variable is different from waiting_for_input in keyboard.c.
+ It is used to communicate to a lisp process-filter/sentinel (via the
+ function Fwaiting_for_user_input_p) whether Emacs was waiting
+ for user-input when that process-filter was called.
+ waiting_for_input cannot be used as that is by definition 0 when
+ lisp code is being evalled.
+ This is also used in record_asynch_buffer_change.
+ For that purpose, this must be 0
+ when not inside wait_reading_process_output. */
+ int m_waiting_for_user_input_p;
+ #define waiting_for_user_input_p (current_thread->m_waiting_for_user_input_p)
+
+ /* The OS identifier for this thread. */
+ sys_thread_t thread_id;
+
+ /* The condition variable for this thread. This is associated with
+ the global lock. This thread broadcasts to it when it exits. */
+ sys_cond_t thread_condvar;
+
+ /* This thread might be waiting for some condition. If so, this
+ points to the condition. If the thread is interrupted, the
+ interrupter should broadcast to this condition. */
+ sys_cond_t *wait_condvar;
+
+ /* Threads are kept on a linked list. */
+ struct thread_state *next_thread;
+ };
+
+ /* A mutex in lisp is represented by a system condition variable.
+ The system mutex associated with this condition variable is the
+ global lock.
+
+ Using a condition variable lets us implement interruptibility for
+ lisp mutexes. */
+ typedef struct
+ {
+ /* The owning thread, or NULL if unlocked. */
+ struct thread_state *owner;
+ /* The lock count. */
+ unsigned int count;
+ /* The underlying system condition variable. */
+ sys_cond_t condition;
+ } lisp_mutex_t;
+
+ /* A mutex as a lisp object. */
+ struct Lisp_Mutex
+ {
+ struct vectorlike_header header;
+
+ /* The name of the mutex, or nil. */
+ Lisp_Object name;
+
+ /* The lower-level mutex object. */
+ lisp_mutex_t mutex;
+ };
+
+ /* A condition variable as a lisp object. */
+ struct Lisp_CondVar
+ {
+ struct vectorlike_header header;
+
+ /* The associated mutex. */
+ Lisp_Object mutex;
+
+ /* The name of the condition variable, or nil. */
+ Lisp_Object name;
+
+ /* The lower-level condition variable object. */
+ sys_cond_t cond;
+ };
+
+ extern struct thread_state *current_thread;
+
+ extern void unmark_threads (void);
+ extern void finalize_one_thread (struct thread_state *state);
+ extern void finalize_one_mutex (struct Lisp_Mutex *);
+ extern void finalize_one_condvar (struct Lisp_CondVar *);
+
+ extern void init_threads_once (void);
+ extern void init_threads (void);
+ extern void syms_of_threads (void);
+
+ typedef int select_func (int, fd_set *, fd_set *, fd_set *,
+ struct timespec *, sigset_t *);
+
+ int thread_select (select_func *func, int max_fds, fd_set *rfds,
+ fd_set *wfds, fd_set *efds, struct timespec *timeout,
+ sigset_t *sigmask);
+
+ bool thread_check_current_buffer (struct buffer *);
+
+ #endif /* THREAD_H */
static int sys_access (const char *, int);
extern void *e_malloc (size_t);
extern int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *,
- struct timespec *, void *);
+ struct timespec *, sigset_t *);
extern int sys_dup (int);
-
-
\f
/* Initialization states.
projects / emacs.git / commitdiff