From: Eli Zaretskii Date: Sun, 4 Dec 2016 17:59:17 +0000 (+0200) Subject: Merge branch 'concurrency' X-Git-Tag: emacs-26.0.90~1144^2~17 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=de4624c99ea5bbe38ad5aff7b6461cc5c740d0be;p=emacs.git Merge branch 'concurrency' Conflicts (resolved): configure.ac src/Makefile.in src/alloc.c src/bytecode.c src/emacs.c src/eval.c src/lisp.h src/process.c src/regex.c src/regex.h --- de4624c99ea5bbe38ad5aff7b6461cc5c740d0be diff --cc configure.ac index 2d116de3b6b,6f6ca360881..5aaf006c549 --- a/configure.ac +++ b/configure.ac @@@ -354,10 -353,10 +354,11 @@@ OPTION_DEFAULT_ON([gsettings],[don't co 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 ;; @@@ -1643,19 -1589,17 +1644,19 @@@ AC_CHECK_HEADERS_ONCE 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 ]], [[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 ]], + [[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 @@@ -3866,17 -3702,22 +3883,17 @@@ AC_CHECK_FUNCS(accept4 fchdir gethostna 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 ]]) dnl Cannot use AC_CHECK_FUNCS AC_CACHE_CHECK([for __builtin_unwind_init], @@@ -5309,11 -5224,9 +5326,12 @@@ AS_ECHO([" Does Emacs use -lXaw3d 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 diff --cc lisp/subr.el index 5da5bf8388a,b2bc58212a6..1502bed3e4d --- a/lisp/subr.el +++ b/lisp/subr.el @@@ -4951,28 -4921,22 +4951,42 @@@ as a list." (match-string 1 subdir) subdir)) "-pkg.el")) + + ;;; 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))))) + ;;; 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.") diff --cc src/Makefile.in index dc0bfff9b33,0f30ae2c6b1..a8c12848cee --- a/src/Makefile.in +++ b/src/Makefile.in @@@ -407,9 -381,8 +407,10 @@@ base_obj = dispnew.o frame.o scroll.o x 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) diff --cc src/bytecode.c index 868c0148d30,476836b1f40..3ac94055f33 --- a/src/bytecode.c +++ b/src/bytecode.c @@@ -280,10 -294,68 +280,68 @@@ enum byte_code_o 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 - /* 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; */ + + + /* 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++) + + /* 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. */ @@@ -308,6 -382,60 +366,29 @@@ #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; @@@ -355,25 -509,29 +436,26 @@@ exec_byte_code (Lisp_Object bytestr, Li 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; @@@ -508,10 -708,16 +590,15 @@@ 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; } @@@ -666,72 -909,107 +753,85 @@@ 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): @@@ -791,11 -1082,15 +891,15 @@@ 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; @@@ -1364,7 -1907,7 +1468,7 @@@ 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): diff --cc src/emacs.c index f633f09098d,f91e5499916..bf2f5588d1c --- a/src/emacs.c +++ b/src/emacs.c @@@ -155,11 -161,12 +155,7 @@@ bool running_asynch_code 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 @@@ -686,42 -729,21 +681,43 @@@ main (int argc, char **argv /* 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 diff --cc src/eval.c index 724f0018a58,cc3cf3257ea..c08f93aee0c --- a/src/eval.c +++ b/src/eval.c @@@ -46,6 -45,6 +46,8 @@@ Lisp_Object Vautoload_queue 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]. */ @@@ -62,7 -61,7 +64,7 @@@ /* 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 @@@ -227,11 -233,13 +237,12 @@@ init_eval (void { /* 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; @@@ -1390,50 -1393,13 +1402,51 @@@ internal_condition_case_n (Lisp_Object 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; } @@@ -3144,6 -2948,44 +3157,44 @@@ let_shadows_global_binding_p (Lisp_Obje return 0; } + void + do_specbind (struct Lisp_Symbol *sym, union specbinding *bind, + Lisp_Object value) + { + switch (sym->redirect) + { + case SYMBOL_PLAINVAL: - if (!sym->constant) ++ 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; + } + } + - set_internal (specpdl_symbol (bind), value, Qnil, 1); ++ set_internal (specpdl_symbol (bind), value, Qnil, SET_INTERNAL_BIND); + break; + + default: - abort (); ++ 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. @@@ -3263,7 -3104,80 +3313,84 @@@ record_unwind_protect_void (void (*func 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 + 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: - { /* 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) ++ { /* 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_SYMBOL_VAL (sym, specpdl_old_value (this_binding)); ++ 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, 1); ++ set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND); + } + break; + } + } + + void do_nothing (void) {} diff --cc src/lisp.h index 94f1152a56e,8f61f486924..d4da32e3ebf --- a/src/lisp.h +++ b/src/lisp.h @@@ -802,9 -816,9 +840,11 @@@ enum pvec_typ 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, @@@ -3213,14 -3211,33 +3286,11 @@@ struct handle 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. @@@ -3620,11 -3629,10 +3690,12 @@@ extern void mark_object (Lisp_Object) #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; @@@ -3965,15 -3956,10 +4037,18 @@@ Lisp_Object backtrace_top_function (voi 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); @@@ -4252,9 -4234,9 +4327,11 @@@ extern int read_bytecode_char (bool) /* 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); diff --cc src/process.c index 49340b120ef,5e9b687ba60..e538c86fcf5 --- a/src/process.c +++ b/src/process.c @@@ -131,20 -125,15 +131,20 @@@ static struct rlimit nofile_limit #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 . 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 @@@ -257,49 -240,22 +257,24 @@@ static bool keyboard_bit_set (fd_set *) 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; @@@ -476,22 -478,35 +491,33 @@@ add_write_fd (int fd, fd_callback func 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; + } } } @@@ -500,9 -515,17 +526,15 @@@ 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; @@@ -768,19 -883,27 +905,40 @@@ remove_process (register Lisp_Object pr 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 + DEFUN ("processp", Fprocessp, Sprocessp, 1, 1, 0, doc: /* Return t if OBJECT is a process. */) @@@ -1066,23 -1170,6 +1224,17 @@@ DEFUN ("process-mark", Fprocess_mark, S return XPROCESS (process)->mark; } +static void +set_process_filter_masks (struct Lisp_Process *p) +{ + if (EQ (p->filter, Qt) && !EQ (p->status, Qlisten)) - { - FD_CLR (p->infd, &input_wait_mask); - FD_CLR (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)) - { - FD_SET (p->infd, &input_wait_mask); - FD_SET (p->infd, &non_keyboard_wait_mask); - } ++ 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. @@@ -1167,11 -1262,45 +1319,47 @@@ See `set-process-sentinel' for more inf 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); @@@ -2990,590 -3080,112 +3162,583 @@@ usage: (make-serial-process &rest ARGS 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. @@@ -4366,26 -4308,13 +4531,11 @@@ deactivate_process (Lisp_Object proc } #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 (); } } @@@ -4670,98 -4611,6 +4824,87 @@@ server_accept_connection (Lisp_Object s exec_sentinel (proc, concat3 (open_from, host_string, nl)); } +#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 +} + - /* 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; - static void wait_reading_process_output_unwind (int data) { @@@ -5009,14 -4806,18 +5157,14 @@@ wait_reading_process_output (intmax_t t 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 @@@ -5183,26 -4988,18 +5331,27 @@@ 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 @@@ -5505,8 -5299,10 +5653,9 @@@ 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; @@@ -5564,29 -5347,17 +5710,26 @@@ } 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. */ @@@ -7811,29 -7537,12 +7948,24 @@@ init_process_emacs (int sockfd catch_child_signal (); } +#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 + - 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; + 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; diff --cc src/regex.c index afd0d180316,a03e9c46baa..bb046858dfe --- a/src/regex.c +++ b/src/regex.c @@@ -1139,8 -1197,14 +1139,7 @@@ print_double_string (re_char *where, re #endif /* not DEBUG */ -/* 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 - #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. */ @@@ -1166,7 -1231,17 +1166,20 @@@ re_set_syntax (reg_syntax_t syntax } 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 /* 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. diff --cc src/regex.h index 4922440e472,9cd3f0dce7c..2d720e68f22 --- a/src/regex.h +++ b/src/regex.h @@@ -175,13 -168,9 +175,15 @@@ typedef unsigned long reg_syntax_t #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. */ diff --cc src/thread.c index 00000000000,1ff485f0f78..f5b04e4b231 mode 000000,100644..100644 --- a/src/thread.c +++ b/src/thread.c @@@ -1,0 -1,976 +1,975 @@@ + /* 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 . */ + + + #include + #include + #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; + + + + /* m_specpdl is set when the thread is created and cleared when the + thread dies. */ + #define thread_alive_p(STATE) ((STATE)->m_specpdl != NULL) + + + + 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); + } + + + + 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; + } + + + + 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); + } + + + + 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); + } + + + + 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; + } + + + + 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); + } + + + + 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. */ - 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; + } + + /* 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; + } + + + + 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; + } + + + + 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"); + } diff --cc src/thread.h index 00000000000,91bab8284e6..a089c7de573 mode 000000,100644..100644 --- a/src/thread.h +++ b/src/thread.h @@@ -1,0 -1,244 +1,248 @@@ + /* 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 . */ + + #ifndef THREAD_H + #define THREAD_H + + #include "regex.h" + + #ifdef WINDOWSNT + #include + #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. */ ++ 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 */ diff --cc src/w32.c index 086c1acfb38,93eb6284cf2..7a80275a7c8 --- a/src/w32.c +++ b/src/w32.c @@@ -272,9 -255,11 +272,9 @@@ static BOOL WINAPI revert_to_self (void 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); - - /* Initialization states.