commit 595a4d6bfd5aad79fb3ab681ae06f0739a4a5701 (HEAD, refs/remotes/origin/master) Author: Glenn Morris Date: Sat Dec 10 19:40:34 2016 -0800 ; Change maintainer comment Ref http://debbugs.gnu.org/10934#23 diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 1703576..1138b4d 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -4,7 +4,7 @@ ;; Author: Ilya Zakharevich ;; Bob Olson -;; Maintainer: Ilya Zakharevich +;; Maintainer: emacs-devel@gnu.org ;; Keywords: languages, Perl ;; This file is part of GNU Emacs. commit 4aa6d4b18802dda47fa9c7cfc56ddba21b1a163a Author: Glenn Morris Date: Sat Dec 10 19:37:59 2016 -0800 Improve previous cperl-mode change * lisp/progmodes/cperl-mode.el (cperl-mode-abbrev-table): Improve previous change. diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 79c9e56..1703576 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -1126,7 +1126,28 @@ versions of Emacs." ;; expansion manually. Any other suggestions? (require 'cl)) -(defvar cperl-mode-abbrev-table nil +(define-abbrev-table 'cperl-mode-abbrev-table + '( + ("if" "if" cperl-electric-keyword :system t) + ("elsif" "elsif" cperl-electric-keyword :system t) + ("while" "while" cperl-electric-keyword :system t) + ("until" "until" cperl-electric-keyword :system t) + ("unless" "unless" cperl-electric-keyword :system t) + ("else" "else" cperl-electric-else :system t) + ("continue" "continue" cperl-electric-else :system t) + ("for" "for" cperl-electric-keyword :system t) + ("foreach" "foreach" cperl-electric-keyword :system t) + ("formy" "formy" cperl-electric-keyword :system t) + ("foreachmy" "foreachmy" cperl-electric-keyword :system t) + ("do" "do" cperl-electric-keyword :system t) + ("=pod" "=pod" cperl-electric-pod :system t) + ("=over" "=over" cperl-electric-pod :system t) + ("=head1" "=head1" cperl-electric-pod :system t) + ("=head2" "=head2" cperl-electric-pod :system t) + ("pod" "pod" cperl-electric-pod :system t) + ("over" "over" cperl-electric-pod :system t) + ("head1" "head1" cperl-electric-pod :system t) + ("head2" "head2" cperl-electric-pod :system t)) "Abbrev table in use in CPerl mode buffers.") (add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))) @@ -1708,29 +1729,6 @@ or as help on variables `cperl-tips', `cperl-problems', (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command [(control c) (control h) f]))) - (let ((prev-a-c abbrevs-changed)) - (define-abbrev-table 'cperl-mode-abbrev-table '( - ("if" "if" cperl-electric-keyword :system t) - ("elsif" "elsif" cperl-electric-keyword :system t) - ("while" "while" cperl-electric-keyword :system t) - ("until" "until" cperl-electric-keyword :system t) - ("unless" "unless" cperl-electric-keyword :system t) - ("else" "else" cperl-electric-else :system t) - ("continue" "continue" cperl-electric-else :system t) - ("for" "for" cperl-electric-keyword :system t) - ("foreach" "foreach" cperl-electric-keyword :system t) - ("formy" "formy" cperl-electric-keyword :system t) - ("foreachmy" "foreachmy" cperl-electric-keyword :system t) - ("do" "do" cperl-electric-keyword :system t) - ("=pod" "=pod" cperl-electric-pod :system t) - ("=over" "=over" cperl-electric-pod :system t) - ("=head1" "=head1" cperl-electric-pod :system t) - ("=head2" "=head2" cperl-electric-pod :system t) - ("pod" "pod" cperl-electric-pod :system t) - ("over" "over" cperl-electric-pod :system t) - ("head1" "head1" cperl-electric-pod :system t) - ("head2" "head2" cperl-electric-pod :system t))) - (setq abbrevs-changed prev-a-c)) (setq local-abbrev-table cperl-mode-abbrev-table) (if (cperl-val 'cperl-electric-keywords) (abbrev-mode 1)) commit 3aa3f73b9694d8a237360626601973d21e5c88eb Author: Glenn Morris Date: Sat Dec 10 19:26:25 2016 -0800 Mark default cperl abbrevs as system ones * lisp/progmodes/cperl-mode.el (cperl-mode): Mark our abbrevs as system ones. (Bug#10934) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 9658b8b..79c9e56 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -1710,26 +1710,26 @@ or as help on variables `cperl-tips', `cperl-problems', [(control c) (control h) f]))) (let ((prev-a-c abbrevs-changed)) (define-abbrev-table 'cperl-mode-abbrev-table '( - ("if" "if" cperl-electric-keyword 0) - ("elsif" "elsif" cperl-electric-keyword 0) - ("while" "while" cperl-electric-keyword 0) - ("until" "until" cperl-electric-keyword 0) - ("unless" "unless" cperl-electric-keyword 0) - ("else" "else" cperl-electric-else 0) - ("continue" "continue" cperl-electric-else 0) - ("for" "for" cperl-electric-keyword 0) - ("foreach" "foreach" cperl-electric-keyword 0) - ("formy" "formy" cperl-electric-keyword 0) - ("foreachmy" "foreachmy" cperl-electric-keyword 0) - ("do" "do" cperl-electric-keyword 0) - ("=pod" "=pod" cperl-electric-pod 0) - ("=over" "=over" cperl-electric-pod 0) - ("=head1" "=head1" cperl-electric-pod 0) - ("=head2" "=head2" cperl-electric-pod 0) - ("pod" "pod" cperl-electric-pod 0) - ("over" "over" cperl-electric-pod 0) - ("head1" "head1" cperl-electric-pod 0) - ("head2" "head2" cperl-electric-pod 0))) + ("if" "if" cperl-electric-keyword :system t) + ("elsif" "elsif" cperl-electric-keyword :system t) + ("while" "while" cperl-electric-keyword :system t) + ("until" "until" cperl-electric-keyword :system t) + ("unless" "unless" cperl-electric-keyword :system t) + ("else" "else" cperl-electric-else :system t) + ("continue" "continue" cperl-electric-else :system t) + ("for" "for" cperl-electric-keyword :system t) + ("foreach" "foreach" cperl-electric-keyword :system t) + ("formy" "formy" cperl-electric-keyword :system t) + ("foreachmy" "foreachmy" cperl-electric-keyword :system t) + ("do" "do" cperl-electric-keyword :system t) + ("=pod" "=pod" cperl-electric-pod :system t) + ("=over" "=over" cperl-electric-pod :system t) + ("=head1" "=head1" cperl-electric-pod :system t) + ("=head2" "=head2" cperl-electric-pod :system t) + ("pod" "pod" cperl-electric-pod :system t) + ("over" "over" cperl-electric-pod :system t) + ("head1" "head1" cperl-electric-pod :system t) + ("head2" "head2" cperl-electric-pod :system t))) (setq abbrevs-changed prev-a-c)) (setq local-abbrev-table cperl-mode-abbrev-table) (if (cperl-val 'cperl-electric-keywords) commit 3fd44333e91f4575bfa746e6f21406c788001c01 Author: Glenn Morris Date: Sat Dec 10 19:18:24 2016 -0800 Revert earlier Ffset change * src/data.c (Ffset): Allow nil again, since it caused eager macro-expansion failures. diff --git a/src/data.c b/src/data.c index 52cfe4a..09d94f5 100644 --- a/src/data.c +++ b/src/data.c @@ -733,9 +733,6 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0, { register Lisp_Object function; CHECK_SYMBOL (symbol); - /* Perhaps not quite the right error signal, but seems good enough. */ - if (NILP (symbol)) - xsignal1 (Qsetting_constant, symbol); function = XSYMBOL (symbol)->function; commit f37f93f364aed34275f515a8c933f48a0e2735b9 Author: Glenn Morris Date: Sat Dec 10 19:03:28 2016 -0800 Tweaks for message bogus address detection * lisp/gnus/message.el (message-bogus-recipient-p): Do not require "@", since some mailers deliver to local addresses without one. (Bug#23054) Move "@.*@" from here... (message-bogus-addresses): ...to here, so it can be customized. diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 448ba7b..5446aa2 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -4206,14 +4206,14 @@ not have PROP." (nreverse regions))) (defcustom message-bogus-addresses - '("noreply" "nospam" "invalid" "@@" "[^[:ascii:]].*@" "[ \t]") + '("noreply" "nospam" "invalid" "@.*@" "[^[:ascii:]].*@" "[ \t]") "List of regexps of potentially bogus mail addresses. See `message-check-recipients' how to setup checking. This list should make it possible to catch typos or warn about spam-trap addresses. It doesn't aim to verify strict RFC conformance." - :version "23.1" ;; No Gnus + :version "26.1" ; @@ -> @.*@ :group 'message-headers :type '(choice (const :tag "None" nil) @@ -4222,7 +4222,7 @@ conformance." (const "noreply") (const "nospam") (const "invalid") - (const :tag "duplicate @" "@@") + (const :tag "duplicate @" "@.*@") (const :tag "non-ascii local part" "[^[:ascii:]].*@") (const :tag "`_' in domain part" "@.*_") (const :tag "whitespace" "[ \t]")) @@ -4339,8 +4339,6 @@ An address might be bogus if if there's a matching entry in (mapc (lambda (address) (setq address (or (cadr address) "")) (when (or (string= "" address) - (not (string-match "@" address)) - (string-match "@.*@" address) (and message-bogus-addresses (let ((re (if (listp message-bogus-addresses) commit ba8e883fa30f1267c27751c1ee9df25a5dde4c0c Author: Glenn Morris Date: Sat Dec 10 18:58:24 2016 -0800 Do not allow nil to be defined as a function * lisp/emacs-lisp/byte-run.el (defun): * src/data.c (Ffset): Do not allow "nil". (Bug#25110) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 69b4f41..9d2a048 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -240,6 +240,7 @@ The return value is undefined. ;; from ;; (defun foo (arg) (toto)). (declare (doc-string 3) (indent 2)) + (or name (error "Cannot define '%s' as a function" name)) (if (null (and (listp arglist) (null (delq t (mapcar #'symbolp arglist))))) diff --git a/src/data.c b/src/data.c index 09d94f5..52cfe4a 100644 --- a/src/data.c +++ b/src/data.c @@ -733,6 +733,9 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0, { register Lisp_Object function; CHECK_SYMBOL (symbol); + /* Perhaps not quite the right error signal, but seems good enough. */ + if (NILP (symbol)) + xsignal1 (Qsetting_constant, symbol); function = XSYMBOL (symbol)->function; commit 010733616543f86aed9e351d5754d02864c2ea26 Author: Nicolas Richard Date: Sat Dec 10 17:48:10 2016 -0800 Add some sanity checking of defun arglist * lisp/emacs-lisp/byte-run.el (defun): Check for malformed argument lists. (Bug#15715) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 818c268..69b4f41 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -240,6 +240,10 @@ The return value is undefined. ;; from ;; (defun foo (arg) (toto)). (declare (doc-string 3) (indent 2)) + (if (null + (and (listp arglist) + (null (delq t (mapcar #'symbolp arglist))))) + (error "Malformed arglist: %s" arglist)) (let ((decls (cond ((eq (car-safe docstring) 'declare) (prog1 (cdr docstring) (setq docstring nil))) commit 8d1b753d528f741580e48d2b4a6c9b40ca06c08d Author: Matt Armstrong Date: Sat Dec 10 17:29:51 2016 -0800 Minor shell-mode fix for zsh * lisp/shell.el (shell-mode): Prevent shell-dirstack-query becoming confused by zsh abbreviations. (Bug#24632) Copyright-paperwork-exempt: yes diff --git a/lisp/shell.el b/lisp/shell.el index d1b2e87..cabd1e5 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -590,6 +590,7 @@ buffer." ((string-equal shell "ksh") "echo $PWD ~-") ;; Bypass any aliases. TODO all shells could use this. ((string-equal shell "bash") "command dirs") + ((string-equal shell "zsh") "dirs -l") (t "dirs"))) ;; Bypass a bug in certain versions of bash. (when (string-equal shell "bash") commit 2335b9100b47074a37079fb2c3608505eeac96b7 Author: Andreas Schwab Date: Sat Dec 10 21:13:06 2016 +0100 * Makefile.in (install-etc): Don't prepend $(DESTDIR) to commands in system unit file. diff --git a/Makefile.in b/Makefile.in index 1d06d17..2fead76 100644 --- a/Makefile.in +++ b/Makefile.in @@ -735,8 +735,8 @@ install-etc: client_name=`echo emacsclient | sed '$(TRANSFORM)'`${EXEEXT}; \ sed -e '/^##/d' \ -e "/^Documentation/ s/emacs(1)/$${emacs_name}(1)/" \ - -e "/^ExecStart/ s|emacs|$(DESTDIR)${bindir}/$${exe_name}|" \ - -e "/^ExecStop/ s|emacsclient|$(DESTDIR)${bindir}/$${client_name}|" \ + -e "/^ExecStart/ s|emacs|${bindir}/$${exe_name}|" \ + -e "/^ExecStop/ s|emacsclient|${bindir}/$${client_name}|" \ ${srcdir}/etc/emacs.service > $${tmp}; \ $(INSTALL_DATA) $${tmp} "$(DESTDIR)$(systemdunitdir)/${EMACS_NAME}.service"; \ rm -f $${tmp} commit 25a52ca6b2521623334e5768ae26e46595a1b36b Author: Glenn Morris Date: Sat Dec 10 10:19:06 2016 -0800 ; Fix copyright years in new files diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi index 6237392..7ecfb19 100644 --- a/doc/lispref/threads.texi +++ b/doc/lispref/threads.texi @@ -1,7 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Emacs Lisp Reference Manual. -@c Copyright (C) 2012, 2013 -@c Free Software Foundation, Inc. +@c Copyright (C) 2012-2016 Free Software Foundation, Inc. @c See the file elisp.texi for copying conditions. @node Threads @chapter Threads diff --git a/src/systhread.c b/src/systhread.c index c11e024..369d8f8 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -1,5 +1,5 @@ /* System thread definitions - Copyright (C) 2012, 2013 Free Software Foundation, Inc. +Copyright (C) 2012-2016 Free Software Foundation, Inc. This file is part of GNU Emacs. diff --git a/src/systhread.h b/src/systhread.h index b38fd8f..ffe2998 100644 --- a/src/systhread.h +++ b/src/systhread.h @@ -1,5 +1,5 @@ /* System thread definitions - Copyright (C) 2012, 2013 Free Software Foundation, Inc. +Copyright (C) 2012-2016 Free Software Foundation, Inc. This file is part of GNU Emacs. diff --git a/src/thread.c b/src/thread.c index ae2ce3d..3e61723 100644 --- a/src/thread.c +++ b/src/thread.c @@ -1,5 +1,5 @@ /* Threading code. - Copyright (C) 2012, 2013 Free Software Foundation, Inc. +Copyright (C) 2012-2016 Free Software Foundation, Inc. This file is part of GNU Emacs. diff --git a/src/thread.h b/src/thread.h index a9de754..6174032 100644 --- a/src/thread.h +++ b/src/thread.h @@ -1,5 +1,5 @@ /* Thread definitions - Copyright (C) 2012, 2013 Free Software Foundation, Inc. +Copyright (C) 2012-2016 Free Software Foundation, Inc. This file is part of GNU Emacs. diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el index c65b642..4631882 100644 --- a/test/src/thread-tests.el +++ b/test/src/thread-tests.el @@ -1,6 +1,6 @@ ;;; threads.el --- tests for threads. -;; Copyright (C) 2012, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. commit 759415df2e06ded3c06372af3bdee8871c3d179e Author: Philipp Stephani Date: Sat Dec 10 18:23:15 2016 +0100 ; Update file name in comment diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index f2e397a..fc7056c 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -130,7 +130,7 @@ and a string describing how the process finished.") (defvar compilation-num-errors-found) ;; If you make any changes to `compilation-error-regexp-alist-alist', -;; be sure to run the ERT test in test/automated/compile-tests.el. +;; be sure to run the ERT test in test/lisp/progmodes/compile-tests.el. ;; emacs -batch -l compile-tests.el -f ert-run-tests-batch-and-exit (defvar compilation-error-regexp-alist-alist commit 2412a1fc05fe9f89b171d0781c2d530923f48adc Merge: fc0fd24 828b456 Author: Eli Zaretskii Date: Sat Dec 10 18:54:43 2016 +0200 Support concurrency in Emacs Lisp Merge branch 'test-concurrency' * src/thread.c: * src/thread.h: * src/systhread.c: * src/systhread.h: New files. * src/xgselect.c (xg_select): Avoid using SAFE_NALLOCA and use xnmalloc unconditionally. * src/window.c (struct save_window_data): Rename current_buffer to f_current_buffer. * src/w32proc.c (sys_select): Change the function signature to closer fit 'pselect' on Posix hosts. * src/search.c: * src/regex.h: Convert some globals to macros that reference thread-specific values. * src/process.c (pset_thread, add_non_keyboard_read_fd) (add_process_read_fd, add_non_blocking_write_fd) (recompute_input_desc, compute_input_wait_mask) (compute_non_process_wait_mask, compute_non_keyboard_wait_mask) (compute_write_mask, clear_waiting_thread_info) (update_processes_for_thread_death, Fset_process_thread) (Fprocess_thread): New functions. (enum fd_bits): New enumeration. (fd_callback_data): Add 'thread' and 'waiting_thread', rename 'condition' to 'flags'. (set_process_filter_masks, create_process, create_pty) (Fmake_serial_process, finish_after_tls_connection) (connect_network_socket, deactivate_process) (server_accept_connection, wait_reading_process_output) (Fcontinue_process, Fstop_process, keyboard_bit_set) (add_timer_wait_descriptor, add_keyboard_wait_descriptor) (delete_keyboard_wait_descriptor): Use the new functions instead of manipulating fd flags and masks directly. (syms_of_process): Defsubr the new primitives. * src/print.c (print_object): Print threads, mutexes, and conditional variables. * src/lisp.h (enum pvec_type): New values PVEC_THREAD, PVEC_MUTEX, and PVEC_CONDVAR. (XTHREAD, XMUTEX, XCONDVAR, THREADP, MUTEXP, CONDVARP) (CHECK_THREAD, CHECK_MUTEX, CHECK_CONDVAR): New inline functions. (XSETTHREAD, XSETMUTEX, XSETCONDVAR): New macros. (struct handler): Add back byte_stack. Rename lisp_eval_depth to f_lisp_eval_depth. * src/eval.c (specpdl_kind, specpdl_arg, do_specbind) (rebind_for_thread_switch, do_one_unbind) (unbind_for_thread_switch): New functions. (init_eval): 'handlerlist' is not malloc'ed. (specbind): Call do_specbind. (unbind_to): Call do_one_unbind. (mark_specpdl): Accept 2 arguments. (mark_specpdl): Mark the saved value in a let-binding. * src/emacs.c (main): Call init_threads_once, init_threads, and syms_of_threads. * src/data.c (Ftype_of): Support thread, mutex, and condvar objects. (Fthreadp, Fmutexp, Fcondition_variable_p): New functions. (syms_of_data): DEFSYM and defsubr new symbols and primitives. * src/bytecode.c (struct byte_stack, FETCH, CHECK_RANGE) (BYTE_CODE_QUIT): Add back. (exec_byte_code): Add back byte stack manipulation. * src/alloc.c (cleanup_vector): Handle threads, mutexes, and conditional variables. (mark_stack): Now extern; accept additional argument 'bottom'. (flush_stack_call_func): New function. (garbage_collect_1): Call mark_threads and unmark_threads. Don't mark handlers. * src/.gdbinit (xbytecode): Add back. * test/src/thread-tests.el: New tests. * test/src/data-tests.el (binding-test-manual) (binding-test-setq-default, binding-test-makunbound) (binding-test-defvar-bool, binding-test-defvar-int) (binding-test-set-constant-t, binding-test-set-constant-nil) (binding-test-set-constant-keyword) (binding-test-set-constant-nil): New tests. * doc/lispref/processes.texi (Processes and Threads): New subsection. * doc/lispref/threads.texi: New file * doc/lispref/elisp.texi (Top): Include it. * doc/lispref/objects.texi (Thread Type, Mutex Type) (Condition Variable Type): New subsections. (Type Predicates): Add thread-related predicates. * doc/lispref/objects.texi (Editing Types): * doc/lispref/elisp.texi (Top): Update higher-level menus. * etc/NEWS: Mention concurrency features. commit 828b4560cd4a0d8cb9b7a7a3e20ff0c53ba86cfa (refs/remotes/origin/test-concurrency) Author: Eli Zaretskii Date: Sat Dec 10 11:42:48 2016 +0200 Fix error messages in thread.c * src/thread.c (lisp_mutex_unlock, Fcondition_wait) (Fcondition_notify, Fthread_join): Fix error messages. diff --git a/src/thread.c b/src/thread.c index ee5b82d..ae2ce3d 100644 --- a/src/thread.c +++ b/src/thread.c @@ -144,7 +144,7 @@ static int lisp_mutex_unlock (lisp_mutex_t *mutex) { if (mutex->owner != current_thread) - error ("blah"); + error ("Cannot unlock mutex owned by another thread"); if (--mutex->count > 0) return 0; @@ -375,7 +375,7 @@ this thread. */) mutex = XMUTEX (cvar->mutex); if (!lisp_mutex_owned_p (&mutex->mutex)) - error ("fixme"); + error ("Condition variable's mutex is not held by current thread"); flush_stack_call_func (condition_wait_callback, cvar); @@ -430,7 +430,7 @@ thread. */) mutex = XMUTEX (cvar->mutex); if (!lisp_mutex_owned_p (&mutex->mutex)) - error ("fixme"); + error ("Condition variable's mutex is not held by current thread"); args.cvar = cvar; args.all = !NILP (all); @@ -855,7 +855,7 @@ It is an error for a thread to try to join itself. */) tstate = XTHREAD (thread); if (tstate == current_thread) - error ("cannot join current thread"); + error ("Cannot join current thread"); if (thread_alive_p (tstate)) flush_stack_call_func (thread_join_callback, tstate); commit c364d62f89a499d22f06f63e81ec7819f51596fa Author: Eli Zaretskii Date: Sat Dec 10 11:31:11 2016 +0200 Improve doc strings in thread.c * src/thread.c (Fmake_condition_variable, Fcondition_wait) (Fcondition_notify, Fcondition_mutex, Fcondition_name, Fmake_thread) (Fthread_join, Fall_threads): Doc fixes. diff --git a/src/thread.c b/src/thread.c index b2f8561..ee5b82d 100644 --- a/src/thread.c +++ b/src/thread.c @@ -301,7 +301,7 @@ finalize_one_mutex (struct Lisp_Mutex *mutex) DEFUN ("make-condition-variable", Fmake_condition_variable, Smake_condition_variable, 1, 2, 0, - doc: /* Make a condition variable. + doc: /* Make a condition variable associated with MUTEX. A condition variable provides a way for a thread to sleep while waiting for a state change. @@ -355,23 +355,23 @@ condition_wait_callback (void *arg) } 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. + doc: /* Wait for the condition variable COND to be notified. +COND is the condition variable to wait on. -The mutex associated with CONDITION must be held when this is called. +The mutex associated with COND 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 releases the mutex and waits for COND 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) +`condition-wait' returns, COND's mutex will again be locked by +this thread. */) + (Lisp_Object cond) { struct Lisp_CondVar *cvar; struct Lisp_Mutex *mutex; - CHECK_CONDVAR (condition); - cvar = XCONDVAR (condition); + CHECK_CONDVAR (cond); + cvar = XCONDVAR (cond); mutex = XMUTEX (cvar->mutex); if (!lisp_mutex_owned_p (&mutex->mutex)) @@ -409,24 +409,24 @@ condition_notify_callback (void *arg) } DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0, - doc: /* Notify a condition variable. -This wakes a thread waiting on CONDITION. + doc: /* Notify COND, a condition variable. +This wakes a thread waiting on COND. If ALL is non-nil, all waiting threads are awoken. -The mutex associated with CONDITION must be held when this is called. +The mutex associated with COND must be held when this is called. It is an error if it is not held. -This releases the mutex when notifying CONDITION. When +This releases COND's mutex when notifying COND. When `condition-notify' returns, the mutex will again be locked by this thread. */) - (Lisp_Object condition, Lisp_Object all) + (Lisp_Object cond, Lisp_Object all) { struct Lisp_CondVar *cvar; struct Lisp_Mutex *mutex; struct notify_args args; - CHECK_CONDVAR (condition); - cvar = XCONDVAR (condition); + CHECK_CONDVAR (cond); + cvar = XCONDVAR (cond); mutex = XMUTEX (cvar->mutex); if (!lisp_mutex_owned_p (&mutex->mutex)) @@ -440,26 +440,26 @@ thread. */) } DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0, - doc: /* Return the mutex associated with CONDITION. */) - (Lisp_Object condition) + doc: /* Return the mutex associated with condition variable COND. */) + (Lisp_Object cond) { struct Lisp_CondVar *cvar; - CHECK_CONDVAR (condition); - cvar = XCONDVAR (condition); + CHECK_CONDVAR (cond); + cvar = XCONDVAR (cond); 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) + doc: /* Return the name of condition variable COND. +If no name was given when COND was created, return nil. */) + (Lisp_Object cond) { struct Lisp_CondVar *cvar; - CHECK_CONDVAR (condition); - cvar = XCONDVAR (condition); + CHECK_CONDVAR (cond); + cvar = XCONDVAR (cond); return cvar->name; } @@ -678,7 +678,7 @@ finalize_one_thread (struct thread_state *state) 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. */) +If NAME is given, it must be a string; it names the new thread. */) (Lisp_Object function, Lisp_Object name) { sys_thread_t thr; @@ -843,8 +843,9 @@ thread_join_callback (void *arg) } 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. + doc: /* Wait for THREAD to exit. +This blocks the current thread until THREAD exits or until +the current thread is signaled. It is an error for a thread to try to join itself. */) (Lisp_Object thread) { @@ -863,7 +864,7 @@ It is an error for a thread to try to join itself. */) } DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0, - doc: /* Return a list of all threads. */) + doc: /* Return a list of all the live threads. */) (void) { Lisp_Object result = Qnil; commit e4df093e6058c4338a1ea885d44fd0be7f032b8c Author: Eli Zaretskii Date: Sat Dec 10 11:06:23 2016 +0200 Fix building with check-lisp-object-type * src/thread.c (mark_one_thread): Use NILP to compare with m_saved_last_thing_searched, which is a Lisp object. Reported by Andreas Politz . diff --git a/src/thread.c b/src/thread.c index dda2629..b2f8561 100644 --- a/src/thread.c +++ b/src/thread.c @@ -540,7 +540,7 @@ mark_one_thread (struct thread_state *thread) mark_object (thread->m_last_thing_searched); - if (thread->m_saved_last_thing_searched) + if (!NILP (thread->m_saved_last_thing_searched)) mark_object (thread->m_saved_last_thing_searched); } commit 19bc43020d6afa2265447e2dad43ad617812ab38 Author: Eli Zaretskii Date: Sat Dec 10 10:49:39 2016 +0200 Documentation and commentary improvements * src/lisp.h: * src/regex.c: * src/xgselect.c (xg_select): Improve commentary and formatting. * doc/lispref/objects.texi (Thread Type, Mutex Type) (Condition Variable Type): New subsections. (Type Predicates): Add thread-related predicates. * doc/lispref/objects.texi (Editing Types): * doc/lispref/elisp.texi (Top): Update higher-level menus. diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 415dbe6..4a53a0c 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -349,6 +349,9 @@ Editing Types * Window Configuration Type:: Recording the way a frame is subdivided. * Frame Configuration Type:: Recording the status of all frames. * Process Type:: A subprocess of Emacs running on the underlying OS. +* Thread Type:: A thread of Emacs Lisp execution. +* Mutex Type:: An exclusive lock for thread synchronization. +* Condition Variable Type:: Condition variable for thread synchronization. * Stream Type:: Receive or send characters. * Keymap Type:: What function a keystroke invokes. * Overlay Type:: How an overlay is represented. diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index a76fbb1..5e608bc 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -1410,6 +1410,9 @@ editing. * Window Configuration Type:: Recording the way a frame is subdivided. * Frame Configuration Type:: Recording the status of all frames. * Process Type:: A subprocess of Emacs running on the underlying OS. +* Thread Type:: A thread of Emacs Lisp execution. +* Mutex Type:: An exclusive lock for thread synchronization. +* Condition Variable Type:: Condition variable for thread synchronization. * Stream Type:: Receive or send characters. * Keymap Type:: What function a keystroke invokes. * Overlay Type:: How an overlay is represented. @@ -1625,6 +1628,63 @@ giving the name of the process: return information about, send input or signals to, and receive output from processes. +@node Thread Type +@subsection Thread Type + + A @dfn{thread} in Emacs represents a separate thread of Emacs Lisp +execution. It runs its own Lisp program, has its own current buffer, +and can have subprocesses locked to it, i.e.@: subprocesses whose +output only this thread can accept. @xref{Threads}. + + Thread objects have no read syntax. They print in hash notation, +giving the name of the thread (if it has been given a name) or its +address in core: + +@example +@group +(all-threads) + @result{} (#) +@end group +@end example + +@node Mutex Type +@subsection Mutex Type + + A @dfn{mutex} is an exclusive lock that threads can own and disown, +in order to synchronize between them. @xref{Mutexes}. + + Mutex objects have no read syntax. They print in hash notation, +giving the name of the mutex (if it has been given a name) or its +address in core: + +@example +@group +(make-mutex "my-mutex") + @result{} # +(make-mutex) + @result{} # +@end group +@end example + +@node Condition Variable Type +@subsection Condition Variable Type + + A @dfn{condition variable} is a device for a more complex thread +synchronization than the one supported by a mutex. A thread can wait +on a condition variable, to be woken up when some other thread +notifies the condition. + + Condition variable objects have no read syntax. They print in hash +notation, giving the name of the condition variable (if it has been +given a name) or its address in core: + +@example +@group +(make-condition-variable (make-mutex)) + @result{} # +@end group +@end example + @node Stream Type @subsection Stream Type @@ -1830,6 +1890,9 @@ with references to further information. @item commandp @xref{Interactive Call, commandp}. +@item condition-variable-p +@xref{Condition Variables, condition-variable-p}. + @item consp @xref{List-related Predicates, consp}. @@ -1875,6 +1938,9 @@ with references to further information. @item markerp @xref{Predicates on Markers, markerp}. +@item mutexp +@xref{Mutexes, mutexp}. + @item wholenump @xref{Predicates on Numbers, wholenump}. @@ -1908,6 +1974,9 @@ with references to further information. @item syntax-table-p @xref{Syntax Tables, syntax-table-p}. +@item threadp +@xref{Basic Thread Functions, threadp}. + @item vectorp @xref{Vectors, vectorp}. diff --git a/src/lisp.h b/src/lisp.h index 72ea50d..3c7c3dd 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -845,6 +845,7 @@ enum pvec_type PVEC_THREAD, PVEC_MUTEX, PVEC_CONDVAR, + /* These should be last, check internal_equal to see why. */ PVEC_COMPILED, PVEC_CHAR_TABLE, @@ -3229,6 +3230,7 @@ union specbinding } bt; }; +/* These 3 are defined as macros in thread.h. */ /* extern union specbinding *specpdl; */ /* extern union specbinding *specpdl_ptr; */ /* extern ptrdiff_t specpdl_size; */ diff --git a/src/regex.c b/src/regex.c index e7231d3..f1686cf 100644 --- a/src/regex.c +++ b/src/regex.c @@ -1140,6 +1140,7 @@ print_double_string (re_char *where, re_char *string1, ssize_t size1, #endif /* not DEBUG */ #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. */ diff --git a/src/xgselect.c b/src/xgselect.c index e418e1a..2f23764 100644 --- a/src/xgselect.c +++ b/src/xgselect.c @@ -76,6 +76,9 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds, if (gfds_size < n_gfds) { + /* Avoid using SAFE_NALLOCA, as that implicitly refers to the + current thread. Using xnmalloc avoids thread-switching + problems here. */ gfds = xnmalloc (n_gfds, sizeof *gfds); must_free = 1; gfds_size = n_gfds; commit ad03e7af8b816a9a86480196383eaf080afc28e4 Author: Eli Zaretskii Date: Fri Dec 9 19:04:36 2016 +0200 *src/sysdep.c: Fix a comment. diff --git a/src/sysdep.c b/src/sysdep.c index 46802dd..3d2b9bd 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -63,7 +63,7 @@ along with GNU Emacs. If not, see . */ #define STDERR_FILENO fileno(GetStdHandle(STD_ERROR_HANDLE)) #endif #include "w32.h" -#endif /* not WINDOWSNT */ +#endif /* WINDOWSNT */ #include #include commit a708a5c6bd6d006a39a60ac72465e25d16bbf6aa Author: Eli Zaretskii Date: Fri Dec 9 18:51:59 2016 +0200 Fix compilation error on Fedora 24 * src/sysdep.c [HAVE_H_ERRNO]: Remove declaration of h_errno. Reported by Paul Eggert . diff --git a/src/sysdep.c b/src/sysdep.c index edc3f05..46802dd 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -56,12 +56,6 @@ along with GNU Emacs. If not, see . */ #include #endif /* HAVE_SOCKETS */ -#ifdef TRY_AGAIN -#ifndef HAVE_H_ERRNO -extern int h_errno; -#endif -#endif /* TRY_AGAIN */ - #ifdef WINDOWSNT #define read sys_read #define write sys_write commit 7399f53a3706c8cb6ce27f7fe51fb5dc79e39bc1 Author: Eli Zaretskii Date: Fri Dec 9 18:23:04 2016 +0200 Fix compilation warnings due to prototype of thread_select * src/thread.h : Make the 5th and 6th arguments be 'const'. * src/process.c [WINDOWSNT]: * src/w32proc.c: Make the 5th and 6th argument to sys_select be 'const'. diff --git a/src/process.c b/src/process.c index 7d3cf19..a60814b 100644 --- a/src/process.c +++ b/src/process.c @@ -138,7 +138,7 @@ static struct rlimit nofile_limit; #ifdef WINDOWSNT extern int sys_select (int, fd_set *, fd_set *, fd_set *, - struct timespec *, sigset_t *); + const struct timespec *, const sigset_t *); #endif /* Work around GCC 4.3.0 bug with strict overflow checking; see diff --git a/src/thread.h b/src/thread.h index 6444800..a9de754 100644 --- a/src/thread.h +++ b/src/thread.h @@ -226,7 +226,7 @@ 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 *); + const struct timespec *, const sigset_t *); int thread_select (select_func *func, int max_fds, fd_set *rfds, fd_set *wfds, fd_set *efds, struct timespec *timeout, diff --git a/src/w32.c b/src/w32.c index 7a80275..c6fc7ef 100644 --- a/src/w32.c +++ b/src/w32.c @@ -272,7 +272,7 @@ 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 *, sigset_t *); + const struct timespec *, const sigset_t *); extern int sys_dup (int); diff --git a/src/w32proc.c b/src/w32proc.c index 3ff52c3..6f3a6e0 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -72,7 +72,7 @@ extern BOOL g_b_init_compare_string_w; extern BOOL g_b_init_debug_break_process; int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, - struct timespec *, sigset_t *); + const struct timespec *, const sigset_t *); /* Signal handlers...SIG_DFL == 0 so this is initialized correctly. */ static signal_handler sig_handlers[NSIG]; @@ -2096,7 +2096,7 @@ extern int proc_buffered_char[]; int sys_select (int nfds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, - struct timespec *timeout, sigset_t *ignored) + const struct timespec *timeout, const sigset_t *ignored) { SELECT_TYPE orfds, owfds; DWORD timeout_ms, start_time; commit ae490069eafa68356405fc9719910a4c533f14ea Author: Eli Zaretskii Date: Fri Dec 9 18:04:27 2016 +0200 Fix compilation on Debian GNU/Linux * src/thread.h: Include sys/types.h, for ssize_t that regex.h uses. Reported by Robert Marshall . diff --git a/src/thread.h b/src/thread.h index d4cae36..6444800 100644 --- a/src/thread.h +++ b/src/thread.h @@ -19,6 +19,7 @@ along with GNU Emacs. If not, see . */ #ifndef THREAD_H #define THREAD_H +#include /* for ssize_t used by regex.h */ #include "regex.h" #ifdef WINDOWSNT commit 3ef50c1ff691b0a6c2f56da76f7c1c9b572d8be8 Author: Eli Zaretskii Date: Fri Dec 9 16:03:08 2016 +0200 Fix subtle errors with let-binding of localized variables * src/eval.c (do_specbind): Don't require a "symbol" that is actually a cons cell, in order to call set-default, as there are no longer such bindings. This makes do_specbind work like the pre-concurrency implementation in specbind for bindings of forwarded symbols. Use specpdl_kind to access the type of the binding. (specpdl_kind): New function. diff --git a/src/eval.c b/src/eval.c index 9657f51..5383d7c 100644 --- a/src/eval.c +++ b/src/eval.c @@ -102,6 +102,13 @@ specpdl_symbol (union specbinding *pdl) return pdl->let.symbol; } +static enum specbind_tag +specpdl_kind (union specbinding *pdl) +{ + eassert (pdl->kind >= SPECPDL_LET); + return pdl->let.kind; +} + static Lisp_Object specpdl_old_value (union specbinding *pdl) { @@ -3170,23 +3177,15 @@ do_specbind (struct Lisp_Symbol *sym, union specbinding *bind, 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))) + if (BUFFER_OBJFWDP (SYMBOL_FWD (sym)) + && specpdl_kind (bind) == SPECPDL_LET_DEFAULT) { - Lisp_Object where; - - where = XCAR (XCDR (specpdl_symbol (bind))); - if (NILP (where) - && sym->redirect == SYMBOL_FORWARDED) - { - Fset_default (XCAR (specpdl_symbol (bind)), value); - return; - } + Fset_default (specpdl_symbol (bind), value); + return; } - + /* FALLTHROUGH */ + case SYMBOL_LOCALIZED: set_internal (specpdl_symbol (bind), value, Qnil, SET_INTERNAL_BIND); break; @@ -3361,8 +3360,7 @@ do_one_unbind (union specbinding *this_binding, bool unwinding) break; case SPECPDL_LET: { /* 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. */ + trapped, we can just set it. */ Lisp_Object sym = specpdl_symbol (this_binding); if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL) { commit 54f52a1390c394f42203f39d0b4d73318203e092 Author: Eli Zaretskii Date: Thu Dec 8 20:47:27 2016 +0200 Fix compilation warnings * src/thread.c (Fmake_thread): Call emacs_abort, to avoid compilation warning. diff --git a/src/thread.c b/src/thread.c index 11d55a5..dda2629 100644 --- a/src/thread.c +++ b/src/thread.c @@ -689,7 +689,7 @@ If NAME is given, it names the new thread. */) /* Can't start a thread in temacs. */ if (!initialized) - abort (); + emacs_abort (); if (!NILP (name)) CHECK_STRING (name); commit 128cacda1c79983f0b64773afc029bc757cfb7b8 Author: Eli Zaretskii Date: Thu Dec 8 18:35:40 2016 +0200 Add a NEWS entry. diff --git a/etc/NEWS b/etc/NEWS index f7565b0..256edde 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -74,6 +74,19 @@ for '--daemon'. * Changes in Emacs 26.1 +++ +** Emacs now provides a limited form of concurrency with Lisp threads. +Concurrency in Emacs Lisp is "mostly cooperative", meaning that +Emacs will only switch execution between threads at well-defined +times: when Emacs waits for input, during blocking operations related +to threads (such as mutex locking), or when the current thread +explicitly yields. Global variables are shared among all threads, but +a 'let' binding is thread-local. Each thread also has its own current +buffer and its own match data. + +See the chapter "Threads" in the ELisp manual for full documentation +of these facilities. + ++++ ** The new function 'file-name-case-insensitive-p' tests whether a given file is on a case-insensitive filesystem. commit fa7d1f075fb862ae4ca28390abf33d625dbd2813 Author: Eli Zaretskii Date: Wed Dec 7 21:01:40 2016 +0200 Fix network streams. The original code messed up flags in fd_callback_data[], and also didn't call add_process_read_fd for process-related file descriptors. diff --git a/src/process.c b/src/process.c index e800bf2..7d3cf19 100644 --- a/src/process.c +++ b/src/process.c @@ -454,6 +454,8 @@ add_non_keyboard_read_fd (int fd) { eassert (fd >= 0 && fd < FD_SETSIZE); eassert (fd_callback_info[fd].func == NULL); + + fd_callback_info[fd].flags &= ~KEYBOARD_FD; fd_callback_info[fd].flags |= FOR_READ; if (fd > max_desc) max_desc = fd; @@ -486,12 +488,13 @@ delete_read_fd (int fd) void add_write_fd (int fd, fd_callback func, void *data) { - if (fd > max_desc) - max_desc = fd; + eassert (fd >= 0 && fd < FD_SETSIZE); fd_callback_info[fd].func = func; fd_callback_info[fd].data = data; fd_callback_info[fd].flags |= FOR_WRITE; + if (fd > max_desc) + max_desc = fd; } static void @@ -915,7 +918,7 @@ update_processes_for_thread_death (Lisp_Object dying_thread) { struct Lisp_Process *proc = XPROCESS (process); - proc->thread = Qnil; + pset_thread (proc, Qnil); if (proc->infd >= 0) fd_callback_info[proc->infd].thread = NULL; if (proc->outfd >= 0) @@ -1230,7 +1233,7 @@ set_process_filter_masks (struct Lisp_Process *p) else if (EQ (p->filter, Qt) /* Network or serial process not stopped: */ && !EQ (p->command, Qt)) - add_non_keyboard_read_fd (p->infd); + add_process_read_fd (p->infd); } DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter, @@ -1336,7 +1339,7 @@ If THREAD is nil, the process is unlocked. */) } proc = XPROCESS (process); - proc->thread = thread; + pset_thread (proc, thread); if (proc->infd >= 0) fd_callback_info[proc->infd].thread = tstate; if (proc->outfd >= 0) @@ -2031,7 +2034,8 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) p->pty_flag = pty_flag; pset_status (p, Qrun); - add_process_read_fd (inchannel); + if (!EQ (p->command, Qt)) + add_process_read_fd (inchannel); /* This may signal an error. */ setup_process_coding_systems (process); @@ -2265,7 +2269,7 @@ create_pty (Lisp_Object process) pset_status (p, Qrun); setup_process_coding_systems (process); - add_non_keyboard_read_fd (pty_fd); + add_process_read_fd (pty_fd); pset_tty_name (p, build_string (pty_name)); } @@ -2371,7 +2375,7 @@ usage: (make-pipe-process &rest ARGS) */) eassert (! p->pty_flag); if (!EQ (p->command, Qt)) - add_non_keyboard_read_fd (inchannel); + add_process_read_fd (inchannel); p->adaptive_read_buffering = (NILP (Vprocess_adaptive_read_buffering) ? 0 : EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2); @@ -3107,7 +3111,7 @@ usage: (make-serial-process &rest ARGS) */) eassert (! p->pty_flag); if (!EQ (p->command, Qt)) - add_non_keyboard_read_fd (fd); + add_process_read_fd (fd); if (BUFFERP (buffer)) { @@ -3597,7 +3601,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, 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))) - add_non_keyboard_read_fd (inch); + add_process_read_fd (inch); if (inch > max_desc) max_desc = inch; @@ -4793,7 +4797,9 @@ server_accept_connection (Lisp_Object server, int channel) /* Client processes for accepted connections are not stopped initially. */ if (!EQ (p->filter, Qt)) - add_non_keyboard_read_fd (s); + add_process_read_fd (s); + if (s > max_desc) + max_desc = s; /* Setup coding system for new process based on server process. This seems to be the proper thing to do, as the coding system @@ -5542,7 +5548,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (d->func && ((d->flags & FOR_READ && FD_ISSET (channel, &Available)) - || (d->flags & FOR_WRITE + || ((d->flags & FOR_WRITE) && FD_ISSET (channel, &Writeok)))) d->func (channel, d->data); } @@ -5728,7 +5734,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (0 <= p->infd && !EQ (p->filter, Qt) && !EQ (p->command, Qt)) - add_non_keyboard_read_fd (p->infd); + add_process_read_fd (p->infd); } } } /* End for each file descriptor. */ @@ -6728,7 +6734,7 @@ traffic. */) && p->infd >= 0 && (!EQ (p->filter, Qt) || EQ (p->status, Qlisten))) { - add_non_keyboard_read_fd (p->infd); + add_process_read_fd (p->infd); #ifdef WINDOWSNT if (fd_info[ p->infd ].flags & FILE_SERIAL) PurgeComm (fd_info[ p->infd ].hnd, PURGE_RXABORT | PURGE_RXCLEAR); @@ -7397,7 +7403,8 @@ keyboard_bit_set (fd_set *mask) for (fd = 0; fd <= max_desc; fd++) if (FD_ISSET (fd, mask) - && ((fd_callback_info[fd].flags & KEYBOARD_FD) != 0)) + && ((fd_callback_info[fd].flags & (FOR_READ | KEYBOARD_FD)) + == (FOR_READ | KEYBOARD_FD))) return 1; return 0; @@ -7635,8 +7642,7 @@ void add_timer_wait_descriptor (int fd) { add_read_fd (fd, timerfd_callback, NULL); - if (fd > max_desc) - max_desc = fd; + fd_callback_info[fd].flags &= ~KEYBOARD_FD; } #endif /* HAVE_TIMERFD */ @@ -7661,6 +7667,7 @@ add_keyboard_wait_descriptor (int desc) { #ifdef subprocesses /* Actually means "not MSDOS". */ eassert (desc >= 0 && desc < FD_SETSIZE); + fd_callback_info[desc].flags &= ~PROCESS_FD; fd_callback_info[desc].flags |= (FOR_READ | KEYBOARD_FD); if (desc > max_desc) max_desc = desc; diff --git a/src/w32.c b/src/w32.c index 086c1ac..7a80275 100644 --- a/src/w32.c +++ b/src/w32.c @@ -272,7 +272,7 @@ 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); diff --git a/src/w32proc.c b/src/w32proc.c index c9bc285..3ff52c3 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -72,7 +72,7 @@ extern BOOL g_b_init_compare_string_w; extern BOOL g_b_init_debug_break_process; int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, - struct timespec *, void *); + struct timespec *, sigset_t *); /* Signal handlers...SIG_DFL == 0 so this is initialized correctly. */ static signal_handler sig_handlers[NSIG]; @@ -2096,7 +2096,7 @@ extern int proc_buffered_char[]; int sys_select (int nfds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, - struct timespec *timeout, void *ignored) + struct timespec *timeout, sigset_t *ignored) { SELECT_TYPE orfds, owfds; DWORD timeout_ms, start_time; commit 16ac7c0fc91b5eb09f2a129fc2c01281369f897a Author: Eli Zaretskii Date: Wed Dec 7 19:08:24 2016 +0200 Minimize spurious diffs from master. diff --git a/src/w32.c b/src/w32.c index 7a80275..086c1ac 100644 --- a/src/w32.c +++ b/src/w32.c @@ -272,7 +272,7 @@ 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 *, sigset_t *); + struct timespec *, void *); extern int sys_dup (int); diff --git a/src/w32.h b/src/w32.h index 760bb14..702bb52 100644 --- a/src/w32.h +++ b/src/w32.h @@ -25,6 +25,7 @@ along with GNU Emacs. If not, see . */ #include + /* File descriptor set emulation. */ /* MSVC runtime library has limit of 64 descriptors by default */ diff --git a/src/w32proc.c b/src/w32proc.c index c4f1f69..c9bc285 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -72,7 +72,7 @@ extern BOOL g_b_init_compare_string_w; extern BOOL g_b_init_debug_break_process; int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, - struct timespec *, sigset_t *); + struct timespec *, void *); /* Signal handlers...SIG_DFL == 0 so this is initialized correctly. */ static signal_handler sig_handlers[NSIG]; @@ -849,8 +849,8 @@ alarm (int seconds) stream is terminated, terminates the reader thread as part of deleting the child_process object. - The sys_select function emulates the Posix 'pselect' function; it - is needed because the Windows 'select' function supports only + The sys_select function emulates the Posix 'pselect' functionality; + it is needed because the Windows 'select' function supports only network sockets, while Emacs expects 'pselect' to work for any file descriptor, including pipes and serial streams. @@ -2096,7 +2096,7 @@ extern int proc_buffered_char[]; int sys_select (int nfds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, - struct timespec *timeout, sigset_t *ignored) + struct timespec *timeout, void *ignored) { SELECT_TYPE orfds, owfds; DWORD timeout_ms, start_time; commit 8ad92413b9349613f9815bd0aaf523896a84b479 Author: Eli Zaretskii Date: Tue Dec 6 20:23:37 2016 +0200 Fix the test suite * test/automated/bindings.el: Contents moved to test/src/data-tests.el. * test/automated/threads.el: Moved to test/src/thread-tests.el. diff --git a/test/automated/bindings.el b/test/automated/bindings.el deleted file mode 100644 index 4b88bae..0000000 --- a/test/automated/bindings.el +++ /dev/null @@ -1,99 +0,0 @@ -;;; bindings.el --- tests for variable bindings - -;; Copyright (C) 2012 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 . - -;;; Code: - -(defvar binding-test-buffer-A (get-buffer-create "A")) -(defvar binding-test-buffer-B (get-buffer-create "B")) - -(defvar binding-test-always-local 'always) -(make-variable-buffer-local 'binding-test-always-local) - -(defvar binding-test-some-local 'some) -(with-current-buffer binding-test-buffer-A - (set (make-local-variable 'binding-test-some-local) 'local)) - -(ert-deftest binding-test-manual () - "A test case from the elisp manual." - (save-excursion - (set-buffer binding-test-buffer-A) - (let ((binding-test-some-local 'something-else)) - (should (eq binding-test-some-local 'something-else)) - (set-buffer binding-test-buffer-B) - (should (eq binding-test-some-local 'some))) - (should (eq binding-test-some-local 'some)) - (set-buffer binding-test-buffer-A) - (should (eq binding-test-some-local 'local)))) - -(ert-deftest binding-test-setq-default () - "Test that a setq-default has no effect when there is a local binding." - (save-excursion - (set-buffer binding-test-buffer-B) - ;; This variable is not local in this buffer. - (let ((binding-test-some-local 'something-else)) - (setq-default binding-test-some-local 'new-default)) - (should (eq binding-test-some-local 'some)))) - -(ert-deftest binding-test-makunbound () - "Tests of makunbound, from the manual." - (save-excursion - (set-buffer binding-test-buffer-B) - (should (boundp 'binding-test-some-local)) - (let ((binding-test-some-local 'outer)) - (let ((binding-test-some-local 'inner)) - (makunbound 'binding-test-some-local) - (should (not (boundp 'binding-test-some-local)))) - (should (and (boundp 'binding-test-some-local) - (eq binding-test-some-local 'outer)))))) - -(ert-deftest binding-test-defvar-bool () - "Test DEFVAR_BOOL" - (let ((display-hourglass 5)) - (should (eq display-hourglass t)))) - -(ert-deftest binding-test-defvar-int () - "Test DEFVAR_INT" - (should-error (setq gc-cons-threshold 5.0) :type 'wrong-type-argument)) - -(ert-deftest binding-test-set-constant-t () - "Test setting the constant t" - (should-error (setq t 'bob) :type 'setting-constant)) - -(ert-deftest binding-test-set-constant-nil () - "Test setting the constant nil" - (should-error (setq nil 'bob) :type 'setting-constant)) - -(ert-deftest binding-test-set-constant-keyword () - "Test setting a keyword constant" - (should-error (setq :keyword 'bob) :type 'setting-constant)) - -(ert-deftest binding-test-set-constant-nil () - "Test setting a keyword to itself" - (should (setq :keyword :keyword))) - -;; More tests to write - -;; kill-local-variable -;; defconst; can modify -;; defvar and defconst modify the local binding [ doesn't matter for us ] -;; various kinds of special internal forwarding objects -;; a couple examples in manual, not enough -;; frame-local vars -;; variable aliases - -;;; bindings.el ends here diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 4c2ea54..de0b8e6 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -256,6 +256,87 @@ comparing the subr with a much slower lisp implementation." (v3 (bool-vector-not v1))) (should (equal v2 v3)))) +;; Tests for variable bindings + +(defvar binding-test-buffer-A (get-buffer-create "A")) +(defvar binding-test-buffer-B (get-buffer-create "B")) + +(defvar binding-test-always-local 'always) +(make-variable-buffer-local 'binding-test-always-local) + +(defvar binding-test-some-local 'some) +(with-current-buffer binding-test-buffer-A + (set (make-local-variable 'binding-test-some-local) 'local)) + +(ert-deftest binding-test-manual () + "A test case from the elisp manual." + (save-excursion + (set-buffer binding-test-buffer-A) + (let ((binding-test-some-local 'something-else)) + (should (eq binding-test-some-local 'something-else)) + (set-buffer binding-test-buffer-B) + (should (eq binding-test-some-local 'some))) + (should (eq binding-test-some-local 'some)) + (set-buffer binding-test-buffer-A) + (should (eq binding-test-some-local 'local)))) + +(ert-deftest binding-test-setq-default () + "Test that a setq-default has no effect when there is a local binding." + (save-excursion + (set-buffer binding-test-buffer-B) + ;; This variable is not local in this buffer. + (let ((binding-test-some-local 'something-else)) + (setq-default binding-test-some-local 'new-default)) + (should (eq binding-test-some-local 'some)))) + +(ert-deftest binding-test-makunbound () + "Tests of makunbound, from the manual." + (save-excursion + (set-buffer binding-test-buffer-B) + (should (boundp 'binding-test-some-local)) + (let ((binding-test-some-local 'outer)) + (let ((binding-test-some-local 'inner)) + (makunbound 'binding-test-some-local) + (should (not (boundp 'binding-test-some-local)))) + (should (and (boundp 'binding-test-some-local) + (eq binding-test-some-local 'outer)))))) + +(ert-deftest binding-test-defvar-bool () + "Test DEFVAR_BOOL" + (let ((display-hourglass 5)) + (should (eq display-hourglass t)))) + +(ert-deftest binding-test-defvar-int () + "Test DEFVAR_INT" + (should-error (setq gc-cons-threshold 5.0) :type 'wrong-type-argument)) + +(ert-deftest binding-test-set-constant-t () + "Test setting the constant t" + (should-error (setq t 'bob) :type 'setting-constant)) + +(ert-deftest binding-test-set-constant-nil () + "Test setting the constant nil" + (should-error (setq nil 'bob) :type 'setting-constant)) + +(ert-deftest binding-test-set-constant-keyword () + "Test setting a keyword constant" + (should-error (setq :keyword 'bob) :type 'setting-constant)) + +(ert-deftest binding-test-set-constant-nil () + "Test setting a keyword to itself" + (should (setq :keyword :keyword))) + +;; More tests to write - +;; kill-local-variable +;; defconst; can modify +;; defvar and defconst modify the local binding [ doesn't matter for us ] +;; various kinds of special internal forwarding objects +;; a couple examples in manual, not enough +;; frame-local vars +;; variable aliases + +;; Tests for watchpoints + (ert-deftest data-tests-variable-watchers () (defvar data-tests-var 0) (let* ((watch-data nil) diff --git a/test/automated/threads.el b/test/src/thread-tests.el similarity index 100% rename from test/automated/threads.el rename to test/src/thread-tests.el commit 137898d89359c63ec05d7bb5eedc2d2f59102a11 Author: Eli Zaretskii Date: Tue Dec 6 20:11:47 2016 +0200 Fix a typo in bytecode.c. diff --git a/src/bytecode.c b/src/bytecode.c index 7d5f85d..6439268 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -656,7 +656,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, if (SYMBOLP (sym) && !EQ (val, Qunbound) && !XSYMBOL (sym)->redirect - && !SYMBOL_TRAPPED_WRITE_P (sym)) + && !SYMBOL_TRAPPED_WRITE_P (sym)) SET_SYMBOL_VAL (XSYMBOL (sym), val); else set_internal (sym, val, Qnil, SET_INTERNAL_SET); @@ -754,7 +754,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bgoto): 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; @@ -778,6 +778,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CHECK_RANGE (op); stack.pc = stack.byte_string_start + op; } + else DISCARD (1); NEXT; CASE (Bgotoifnonnilelsepop): commit 66a5abb102ec1d6e4c327632ef235d1eb6433291 Author: Eli Zaretskii Date: Mon Dec 5 22:50:44 2016 +0200 Fix compilation problems. diff --git a/src/bytecode.c b/src/bytecode.c index 3ac9405..7d5f85d 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -891,7 +891,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, if (sys_setjmp (c->jmp)) { struct handler *c = handlerlist; - int desc; + int dest; top = c->bytecode_top; dest = c->bytecode_dest; handlerlist = c->next; diff --git a/src/eval.c b/src/eval.c index 4405b8b..9657f51 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1440,7 +1440,7 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype) c->tag_or_ch = tag_ch_val; c->val = Qnil; c->next = handlerlist; - c->lisp_eval_depth = lisp_eval_depth; + 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; @@ -3157,7 +3157,7 @@ let_shadows_global_binding_p (Lisp_Object symbol) return 0; } -void +static void do_specbind (struct Lisp_Symbol *sym, union specbinding *bind, Lisp_Object value) { @@ -3332,7 +3332,7 @@ rebind_for_thread_switch (void) if (was_trapped) XSYMBOL (sym)->trapped_write = SYMBOL_UNTRAPPED_WRITE; bind->let.saved_value = Qnil; - do_specbind (XSYMBOL (sym, bind, value, true); + do_specbind (XSYMBOL (sym), bind, value); if (was_trapped) XSYMBOL (sym)->trapped_write = SYMBOL_TRAPPED_WRITE; } @@ -3363,7 +3363,7 @@ do_one_unbind (union specbinding *this_binding, bool unwinding) { /* 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); + Lisp_Object sym = specpdl_symbol (this_binding); if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL) { if (XSYMBOL (sym)->trapped_write == SYMBOL_UNTRAPPED_WRITE) @@ -3399,7 +3399,7 @@ do_one_unbind (union specbinding *this_binding, bool unwinding) } } -void +static void do_nothing (void) {} diff --git a/src/lisp.h b/src/lisp.h index d4da32e..72ea50d 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4328,7 +4328,6 @@ 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); diff --git a/src/process.c b/src/process.c index 7f2a071..e800bf2 100644 --- a/src/process.c +++ b/src/process.c @@ -526,8 +526,6 @@ recompute_max_desc (void) void delete_write_fd (int fd) { - int lim = max_desc; - if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0) { if (--num_pending_connects < 0) @@ -1232,7 +1230,7 @@ set_process_filter_masks (struct Lisp_Process *p) else if (EQ (p->filter, Qt) /* Network or serial process not stopped: */ && !EQ (p->command, Qt)) - add_read_fd (p->infd); + add_non_keyboard_read_fd (p->infd); } DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter, @@ -3281,7 +3279,7 @@ finish_after_tls_connection (Lisp_Object proc) pset_status (p, Qfailed); deactivate_process (proc); } - else if (! FD_ISSET (p->outfd, &connect_wait_mask)) + else if ((fd_callback_info[p->outfd].flags & NON_BLOCKING_CONNECT_FD) == 0) { /* If we cleared the connection wait mask before we did the TLS setup, then we have to say that the process is finally "open" @@ -5730,7 +5728,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (0 <= p->infd && !EQ (p->filter, Qt) && !EQ (p->command, Qt)) - add_read_fd (p->infd); + add_non_keyboard_read_fd (p->infd); } } } /* End for each file descriptor. */ @@ -7675,9 +7673,6 @@ void delete_keyboard_wait_descriptor (int desc) { #ifdef subprocesses - int fd; - int lim = max_desc; - eassert (desc >= 0 && desc < FD_SETSIZE); fd_callback_info[desc].flags &= ~(FOR_READ | KEYBOARD_FD | PROCESS_FD); diff --git a/src/regex.c b/src/regex.c index bb04685..e7231d3 100644 --- a/src/regex.c +++ b/src/regex.c @@ -1146,7 +1146,6 @@ print_double_string (re_char *where, re_char *string1, ssize_t size1, /* This has no initializer because initialized variables in Emacs become read-only after dumping. */ reg_syntax_t re_syntax_options; -#endif /* Specify the precise syntax of regexps for compilation. This provides @@ -1166,20 +1165,7 @@ 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 --git a/src/thread.c b/src/thread.c index f5b04e4..11d55a5 100644 --- a/src/thread.c +++ b/src/thread.c @@ -143,8 +143,6 @@ lisp_mutex_lock (lisp_mutex_t *mutex, int new_count) static int lisp_mutex_unlock (lisp_mutex_t *mutex) { - struct thread_state *self = current_thread; - if (mutex->owner != current_thread) error ("blah"); @@ -160,7 +158,6 @@ lisp_mutex_unlock (lisp_mutex_t *mutex) 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. */ @@ -601,9 +598,6 @@ DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0, 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); diff --git a/src/thread.h b/src/thread.h index a089c7d..d4cae36 100644 --- a/src/thread.h +++ b/src/thread.h @@ -142,18 +142,6 @@ struct thread_state 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 diff --git a/src/w32proc.c b/src/w32proc.c index 2d2d948..c4f1f69 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -72,7 +72,7 @@ extern BOOL g_b_init_compare_string_w; extern BOOL g_b_init_debug_break_process; int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, - struct timespec *, void *); + struct timespec *, sigset_t *); /* Signal handlers...SIG_DFL == 0 so this is initialized correctly. */ static signal_handler sig_handlers[NSIG]; commit e4deba098e0281538a0e7b04d849989f17e5bcc7 Author: Eli Zaretskii Date: Mon Dec 5 20:59:11 2016 +0200 Fix merged code in process.c and eval.c. diff --git a/src/eval.c b/src/eval.c index c08f93a..4405b8b 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3323,15 +3323,24 @@ rebind_for_thread_switch (void) if (bind->kind >= SPECPDL_LET) { Lisp_Object value = specpdl_saved_value (bind); - + Lisp_Object sym = specpdl_symbol (bind); + bool was_trapped = + SYMBOLP (sym) + && XSYMBOL (sym)->trapped_write == SYMBOL_TRAPPED_WRITE; + /* FIXME: This is not clean, and if do_specbind signals an + error, the symbol will be left untrapped. */ + if (was_trapped) + XSYMBOL (sym)->trapped_write = SYMBOL_UNTRAPPED_WRITE; bind->let.saved_value = Qnil; - do_specbind (XSYMBOL (specpdl_symbol (bind)), bind, value); + do_specbind (XSYMBOL (sym, bind, value, true); + if (was_trapped) + XSYMBOL (sym)->trapped_write = SYMBOL_TRAPPED_WRITE; } } } static void -do_one_unbind (union specbinding *this_binding, int unwinding) +do_one_unbind (union specbinding *this_binding, bool unwinding) { eassert (unwinding || this_binding->kind >= SPECPDL_LET); switch (this_binding->kind) @@ -3458,7 +3467,7 @@ unbind_to (ptrdiff_t count, Lisp_Object value) union specbinding this_binding; this_binding = *--specpdl_ptr; - do_one_unbind (&this_binding, 1); + do_one_unbind (&this_binding, true); } if (NILP (Vquit_flag) && !NILP (quitf)) @@ -3476,8 +3485,18 @@ unbind_for_thread_switch (struct thread_state *thr) { if ((--bind)->kind >= SPECPDL_LET) { - bind->let.saved_value = find_symbol_value (specpdl_symbol (bind)); - do_one_unbind (bind, 0); + Lisp_Object sym = specpdl_symbol (bind); + bool was_trapped = + SYMBOLP (sym) + && XSYMBOL (sym)->trapped_write == SYMBOL_TRAPPED_WRITE; + bind->let.saved_value = find_symbol_value (sym); + /* FIXME: This is not clean, and if do_one_unbind signals an + error, the symbol will be left untrapped. */ + if (was_trapped) + XSYMBOL (sym)->trapped_write = SYMBOL_UNTRAPPED_WRITE; + do_one_unbind (bind, false); + if (was_trapped) + XSYMBOL (sym)->trapped_write = SYMBOL_TRAPPED_WRITE; } } } diff --git a/src/process.c b/src/process.c index e538c86..7f2a071 100644 --- a/src/process.c +++ b/src/process.c @@ -1321,7 +1321,8 @@ See `set-process-sentinel' for more info on sentinels. */) DEFUN ("set-process-thread", Fset_process_thread, Sset_process_thread, 2, 2, 0, - doc: /* FIXME */) + doc: /* Set the locking thread of PROCESS to be THREAD. +If THREAD is nil, the process is unlocked. */) (Lisp_Object process, Lisp_Object thread) { struct Lisp_Process *proc; @@ -1348,7 +1349,8 @@ DEFUN ("set-process-thread", Fset_process_thread, Sset_process_thread, DEFUN ("process-thread", Fprocess_thread, Sprocess_thread, 1, 1, 0, - doc: /* FIXME */) + doc: /* Ret the locking thread of PROCESS. +If PROCESS is unlocked, this function returns nil. */) (Lisp_Object process) { CHECK_PROCESS (process); @@ -4573,7 +4575,8 @@ is nil, from any process) before the timeout expired. */) /* Can't wait for a process that is dedicated to a different thread. */ if (!EQ (procp->thread, Qnil) && !EQ (procp->thread, Fcurrent_thread ())) - error ("FIXME"); + error ("Attempt to accept output from process %s locked to thread %s", + SDATA (procp->name), SDATA (XTHREAD (procp->thread)->name)); } else just_this_one = Qnil; @@ -5727,7 +5730,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (0 <= p->infd && !EQ (p->filter, Qt) && !EQ (p->command, Qt)) - delete_read_fd (p->infd); + add_read_fd (p->infd); } } } /* End for each file descriptor. */ @@ -7660,7 +7663,7 @@ add_keyboard_wait_descriptor (int desc) { #ifdef subprocesses /* Actually means "not MSDOS". */ eassert (desc >= 0 && desc < FD_SETSIZE); - fd_callback_info[desc].flags |= FOR_READ | KEYBOARD_FD; + fd_callback_info[desc].flags |= (FOR_READ | KEYBOARD_FD); if (desc > max_desc) max_desc = desc; #endif commit de4624c99ea5bbe38ad5aff7b6461cc5c740d0be Merge: a486fab e7bde34 Author: Eli Zaretskii Date: Sun Dec 4 19:59:17 2016 +0200 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 commit e7bde34e939451d87fb42a36195086bdbe48b5e1 (refs/remotes/origin/concurrency) Author: Eli Zaretskii Date: Tue Nov 3 18:17:06 2015 +0200 ; * src/systhread.c [WINDOWSNT]: Fix typos in comments. diff --git a/src/systhread.c b/src/systhread.c index bde0f02..c11e024 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -207,7 +207,7 @@ uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *); /* Mutexes are implemented as critical sections, because they are faster than Windows mutex objects (implemented in userspace), and - satisfy the requirements, since we only needto synchronize within a + satisfy the requirements, since we only need to synchronize within a single process. */ void sys_mutex_init (sys_mutex_t *mutex) @@ -234,7 +234,7 @@ sys_mutex_destroy (sys_mutex_t *mutex) { /* FIXME: According to MSDN, deleting a critical session that is owned by a thread leaves the other threads waiting for the - critical session in an undefined state. Posix docs seems to say + critical session in an undefined state. Posix docs seem to say the same about pthread_mutex_destroy. Do we need to protect against such calamities? */ DeleteCriticalSection ((LPCRITICAL_SECTION)mutex); @@ -354,6 +354,8 @@ sys_thread_equal (sys_thread_t one, sys_thread_t two) static thread_creation_function *thread_start_address; +/* _beginthread wants a void function, while we are passed a function + that returns a pointer. So we use a wrapper. */ static void w32_beginthread_wrapper (void *arg) { @@ -369,12 +371,10 @@ sys_thread_create (sys_thread_t *thread_ptr, const char *name, the main program. On GNU/Linux, it seems like the stack is 2MB by default, overridden by RLIMIT_STACK at program start time. Not sure what to do with this. See also the comment in - w32proc"new_child. */ + w32proc.c:new_child. */ const unsigned stack_size = 0; uintptr_t thandle; - /* _beginthread wants a void function, while we are passed a - function that returns a pointer. So we use a wrapper. */ thread_start_address = func; /* We use _beginthread rather than CreateThread because the former commit 470e3028d8a741d97349faa8fdeb148d913a49d0 Author: Eli Zaretskii Date: Mon Nov 2 19:04:06 2015 +0200 Fix the MS-Windows build * src/thread.h [WINDOWSNT]: Include sys/socket.h. * src/sysselect.h: Don't define fd_set and FD_* macros for MS-Windows here. * src/w32.h: Define them here. * src/process.h (sys_select): Declare prototype. * src/sysdep.c: * src/process.c: * src/filelock.c: * src/emacs.c: * src/callproc.c: Move inclusion of sys/select.h after lisp.h. * nt/inc/socket.h: Include w32.h instead of sysselect.h diff --git a/nt/inc/sys/socket.h b/nt/inc/sys/socket.h index 6ad1216..067effe 100644 --- a/nt/inc/sys/socket.h +++ b/nt/inc/sys/socket.h @@ -74,7 +74,7 @@ typedef unsigned short uint16_t; /* allow us to provide our own version of fd_set */ #define fd_set ws_fd_set -#include "sysselect.h" +#include "w32.h" #endif /* EMACS_CONFIG_H */ #if defined (HAVE_TIMEVAL) && defined (_MSC_VER) diff --git a/src/callproc.c b/src/callproc.c index a6c7bda..bb21c35 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -27,14 +27,12 @@ along with GNU Emacs. If not, see . */ #include #include -#ifdef WINDOWSNT -#define NOMINMAX -#include /* for fcntl */ -#endif #include "lisp.h" #ifdef WINDOWSNT +#define NOMINMAX +#include /* for fcntl */ #include #include "w32.h" #define _P_NOWAIT 1 /* from process.h */ diff --git a/src/emacs.c b/src/emacs.c index 9dc4e42..f91e549 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -31,20 +31,18 @@ along with GNU Emacs. If not, see . */ #include +#define MAIN_PROGRAM +#include "lisp.h" + #ifdef WINDOWSNT #include #include #include +#include "w32.h" #include "w32heap.h" #endif -#define MAIN_PROGRAM -#include "lisp.h" - #if defined WINDOWSNT || defined HAVE_NTGUI -#ifdef WINDOWSNT -#include "w32.h" -#endif #include "w32select.h" #include "w32font.h" #include "w32common.h" diff --git a/src/filelock.c b/src/filelock.c index b37319c..7f9b6e7 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -40,11 +40,6 @@ along with GNU Emacs. If not, see . */ #include #endif /* __FreeBSD__ */ -#ifdef WINDOWSNT -#include -#include /* for fcntl */ -#endif - #include #include @@ -53,6 +48,8 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "coding.h" #ifdef WINDOWSNT +#include +#include /* for fcntl */ #include "w32.h" /* for dostounix_filename */ #endif diff --git a/src/process.c b/src/process.c index 791f8f5..5e9b687 100644 --- a/src/process.c +++ b/src/process.c @@ -29,6 +29,8 @@ along with GNU Emacs. If not, see . */ #include #include +#include "lisp.h" + /* Only MS-DOS does not define `subprocesses'. */ #ifdef subprocesses @@ -92,8 +94,6 @@ along with GNU Emacs. If not, see . */ #endif /* subprocesses */ -#include "lisp.h" - #include "systime.h" #include "systty.h" @@ -126,7 +126,8 @@ along with GNU Emacs. If not, see . */ #endif #ifdef WINDOWSNT -#include "w32.h" +extern int sys_select (int, fd_set *, fd_set *, fd_set *, + struct timespec *, sigset_t *); #endif /* Work around GCC 4.7.0 bug with strict overflow checking; see diff --git a/src/sysdep.c b/src/sysdep.c index ba6be57..d75dcd3 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -39,17 +39,6 @@ along with GNU Emacs. If not, see . */ #include #include -#ifdef HAVE_SOCKETS -#include -#include -#endif /* HAVE_SOCKETS */ - -#ifdef TRY_AGAIN -#ifndef HAVE_H_ERRNO -extern int h_errno; -#endif -#endif /* TRY_AGAIN */ - #include "lisp.h" #include "sysselect.h" #include "blockinput.h" @@ -68,6 +57,17 @@ extern int h_errno; # include #endif +#ifdef HAVE_SOCKETS +#include +#include +#endif /* HAVE_SOCKETS */ + +#ifdef TRY_AGAIN +#ifndef HAVE_H_ERRNO +extern int h_errno; +#endif +#endif /* TRY_AGAIN */ + #ifdef WINDOWSNT #define read sys_read #define write sys_write diff --git a/src/sysselect.h b/src/sysselect.h index e0f7b4e..d6c5d1c 100644 --- a/src/sysselect.h +++ b/src/sysselect.h @@ -25,40 +25,10 @@ along with GNU Emacs. If not, see . */ #include "lisp.h" -#ifdef WINDOWSNT - -/* File descriptor set emulation. */ - -/* MSVC runtime library has limit of 64 descriptors by default */ -#define FD_SETSIZE 64 -typedef struct { - unsigned int bits[FD_SETSIZE / 32]; -} fd_set; - -/* standard access macros */ -#define FD_SET(n, p) \ - do { \ - if ((n) < FD_SETSIZE) { \ - (p)->bits[(n)/32] |= (1 << (n)%32); \ - } \ - } while (0) -#define FD_CLR(n, p) \ - do { \ - if ((n) < FD_SETSIZE) { \ - (p)->bits[(n)/32] &= ~(1 << (n)%32); \ - } \ - } while (0) -#define FD_ISSET(n, p) ((n) < FD_SETSIZE ? ((p)->bits[(n)/32] & (1 << (n)%32)) : 0) -#define FD_ZERO(p) memset((p), 0, sizeof(fd_set)) - -#define SELECT_TYPE fd_set - -#include "systime.h" -extern int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, - struct timespec *, sigset_t *); - -#else /* not WINDOWSNT */ - +/* The w32 build defines select stuff in w32.h, which is included + where w32 needs it, but not where sysselect.h is included. The w32 + definitions in w32.h are incompatible with the below. */ +#ifndef WINDOWSNT #ifdef FD_SET #ifndef FD_SETSIZE #define FD_SETSIZE 64 diff --git a/src/thread.h b/src/thread.h index d155837..91bab82 100644 --- a/src/thread.h +++ b/src/thread.h @@ -21,6 +21,10 @@ along with GNU Emacs. If not, see . */ #include "regex.h" +#ifdef WINDOWSNT +#include +#endif + #include "sysselect.h" /* FIXME */ #include "systime.h" /* FIXME */ diff --git a/src/w32.c b/src/w32.c index 0966b8d..93eb628 100644 --- a/src/w32.c +++ b/src/w32.c @@ -42,8 +42,6 @@ along with GNU Emacs. If not, see . */ #include #include /* for _mbspbrk, _mbslwr, _mbsrchr, ... */ -#include - #undef access #undef chdir #undef chmod @@ -205,6 +203,7 @@ typedef struct _REPARSE_DATA_BUFFER { #endif /* TCP connection support. */ +#include #undef socket #undef bind #undef connect diff --git a/src/w32.h b/src/w32.h index 7de0547..29a3ae3 100644 --- a/src/w32.h +++ b/src/w32.h @@ -25,6 +25,32 @@ along with GNU Emacs. If not, see . */ #include +/* File descriptor set emulation. */ + +/* MSVC runtime library has limit of 64 descriptors by default */ +#define FD_SETSIZE 64 +typedef struct { + unsigned int bits[FD_SETSIZE / 32]; +} fd_set; + +/* standard access macros */ +#define FD_SET(n, p) \ + do { \ + if ((n) < FD_SETSIZE) { \ + (p)->bits[(n)/32] |= (1 << (n)%32); \ + } \ + } while (0) +#define FD_CLR(n, p) \ + do { \ + if ((n) < FD_SETSIZE) { \ + (p)->bits[(n)/32] &= ~(1 << (n)%32); \ + } \ + } while (0) +#define FD_ISSET(n, p) ((n) < FD_SETSIZE ? ((p)->bits[(n)/32] & (1 << (n)%32)) : 0) +#define FD_ZERO(p) memset((p), 0, sizeof(fd_set)) + +#define SELECT_TYPE fd_set + /* ------------------------------------------------------------------------- */ /* child_process.status values */ commit 39372e1a1032521be74575bb06f95a3898fbae30 Merge: 6a31219 e11aaee Author: Ken Raeburn Date: Sun Nov 1 01:42:21 2015 -0400 merge from trunk commit 6a3121904d76e3b2f63007341d48c5c1af55de80 Author: Barry O'Reilly Date: Sat Oct 19 14:42:38 2013 -0400 * src/eval.c (unbind_for_thread_switch): Fix iteration over the specpdl stack. diff --git a/src/ChangeLog b/src/ChangeLog index 705b9c7..b6ecd5f 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2013-10-19 Barry O'Reilly + + * eval.c (unbind_for_thread_switch): Fix iteration over the + specpdl stack. + 2013-09-01 Eli Zaretskii * eval.c (unbind_for_thread_switch): Accept a 'struct diff --git a/src/eval.c b/src/eval.c index b8a6159..fc16c15 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3488,9 +3488,9 @@ unbind_for_thread_switch (struct thread_state *thr) { union specbinding *bind; - for (bind = thr->m_specpdl_ptr; bind != thr->m_specpdl; --bind) + for (bind = thr->m_specpdl_ptr; bind > thr->m_specpdl;) { - if (bind->kind >= SPECPDL_LET) + if ((--bind)->kind >= SPECPDL_LET) { bind->let.saved_value = find_symbol_value (specpdl_symbol (bind)); do_one_unbind (bind, 0); commit 77936017aff66041231f078e8b269247c721456e Author: Tom Tromey Date: Thu Oct 17 21:32:26 2013 -0600 change condition-variablep to condition-variable-p diff --git a/src/lisp.h b/src/lisp.h index 03628e1..f57b21f 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -792,7 +792,7 @@ extern double extract_float (Lisp_Object); extern Lisp_Object Qprocessp; /* Defined in thread.c. */ -extern Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep; +extern Lisp_Object Qthreadp, Qmutexp, Qcondition_variable_p; /* Defined in window.c. */ extern Lisp_Object Qwindowp; @@ -2538,7 +2538,7 @@ CHECK_MUTEX (Lisp_Object x) LISP_INLINE void CHECK_CONDVAR (Lisp_Object x) { - CHECK_TYPE (CONDVARP (x), Qcondition_variablep, x); + CHECK_TYPE (CONDVARP (x), Qcondition_variable_p, x); } /* Since we can't assign directly to the CAR or CDR fields of a cons diff --git a/src/thread.c b/src/thread.c index f060a00..cd9e916 100644 --- a/src/thread.c +++ b/src/thread.c @@ -33,7 +33,7 @@ static struct thread_state *all_threads = &primary_thread; static sys_mutex_t global_lock; -Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep; +Lisp_Object Qthreadp, Qmutexp, Qcondition_variable_p; @@ -969,6 +969,6 @@ syms_of_threads (void) staticpro (&Qthreadp); Qmutexp = intern_c_string ("mutexp"); staticpro (&Qmutexp); - Qcondition_variablep = intern_c_string ("condition-variablep"); - staticpro (&Qcondition_variablep); + Qcondition_variable_p = intern_c_string ("condition-variable-p"); + staticpro (&Qcondition_variable_p); } commit bed10876dba330b24419a6144dc62db52bb273ab Author: Eli Zaretskii Date: Sun Sep 1 18:43:43 2013 +0300 Fix crashes when unbind_for_thread_switch signals an error. src/eval.c (unbind_for_thread_switch): Accept a 'struct thread_state *' argument and use specpdl_ptr and specpdl of that thread. Fixes crashes if find_symbol_value signals an error. src/thread.c (post_acquire_global_lock): Update current_thread before calling unbind_for_thread_switch. Pass the previous thread to unbind_for_thread_switch. diff --git a/src/ChangeLog b/src/ChangeLog index 3e901d8..705b9c7 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,13 @@ +2013-09-01 Eli Zaretskii + + * eval.c (unbind_for_thread_switch): Accept a 'struct + thread_state *' argument and use specpdl_ptr and specpdl of that + thread. Fixes crashes if find_symbol_value signals an error. + + * thread.c (post_acquire_global_lock): Update current_thread + before calling unbind_for_thread_switch. Pass the previous thread + to unbind_for_thread_switch. + 2013-08-31 Eli Zaretskii * systhread.c (sys_cond_init): Set the 'initialized' member to diff --git a/src/eval.c b/src/eval.c index 68a3691..b8a6159 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3484,11 +3484,11 @@ unbind_to (ptrdiff_t count, Lisp_Object value) } void -unbind_for_thread_switch (void) +unbind_for_thread_switch (struct thread_state *thr) { union specbinding *bind; - for (bind = specpdl_ptr; bind != specpdl; --bind) + for (bind = thr->m_specpdl_ptr; bind != thr->m_specpdl; --bind) { if (bind->kind >= SPECPDL_LET) { diff --git a/src/lisp.h b/src/lisp.h index 51c09e0..03628e1 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3828,7 +3828,7 @@ extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object); extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *); extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object); extern void rebind_for_thread_switch (void); -extern void unbind_for_thread_switch (void); +extern void unbind_for_thread_switch (struct thread_state *); extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); extern _Noreturn void verror (const char *, va_list) ATTRIBUTE_FORMAT_PRINTF (1, 0); diff --git a/src/thread.c b/src/thread.c index 39a2151..f060a00 100644 --- a/src/thread.c +++ b/src/thread.c @@ -55,15 +55,20 @@ static void post_acquire_global_lock (struct thread_state *self) { Lisp_Object buffer; + struct thread_state *prev_thread = current_thread; - if (self != 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) { - /* CURRENT_THREAD is NULL if the previously 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 (current_thread != NULL) - unbind_for_thread_switch (); - current_thread = self; + if (prev_thread != NULL) + unbind_for_thread_switch (prev_thread); rebind_for_thread_switch (); } commit e57df8f77901a3964d21c3d57fb6769cf4511dc2 Author: Eli Zaretskii Date: Sat Aug 31 14:29:05 2013 +0300 Improve MS-Windows implementation of threads. src/systhread.c (sys_cond_init): Set the 'initialized' member to true only if initialization is successful. Initialize wait_count and wait_count_lock. (sys_cond_wait, sys_cond_signal, sys_cond_broadcast): If 'initialized' is false, do nothing. (sys_cond_wait): Fix the implementation to avoid the "missed wakeup" bug: count the waiting threads, and reset the broadcast event once the last thread was released. (sys_cond_signal, sys_cond_broadcast): Use SetEvent instead of PulseEvent. Don't signal the event if no threads are waiting. (sys_cond_destroy): Only close non-NULL handles. (sys_thread_create): Return zero if unsuccessful, 1 if successful. src/systhread.h (w32thread_cond_t): New member 'initialized'. Rename waiters_count and waiters_count_lock to wait_count and wait_count_lock, respectively. diff --git a/src/ChangeLog b/src/ChangeLog index 0aef16d..3e901d8 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,22 @@ +2013-08-31 Eli Zaretskii + + * systhread.c (sys_cond_init): Set the 'initialized' member to + true only if initialization is successful. Initialize wait_count + and wait_count_lock. + (sys_cond_wait, sys_cond_signal, sys_cond_broadcast): If + 'initialized' is false, do nothing. + (sys_cond_wait): Fix the implementation to avoid the "missed + wakeup" bug: count the waiting threads, and reset the broadcast + event once the last thread was released. + (sys_cond_signal, sys_cond_broadcast): Use SetEvent instead of + PulseEvent. Don't signal the event if no threads are waiting. + (sys_cond_destroy): Only close non-NULL handles. + (sys_thread_create): Return zero if unsuccessful, 1 if successful. + + * systhread.h (w32thread_cond_t): New member 'initialized'. + Rename waiters_count and waiters_count_lock to wait_count and + wait_count_lock, respectively. + 2013-08-30 Eli Zaretskii * systhread.h (w32thread_critsect, w32thread_cond_t, sys_mutex_t) diff --git a/src/process.c b/src/process.c index 94ca3d4..899c003 100644 --- a/src/process.c +++ b/src/process.c @@ -497,7 +497,6 @@ void delete_read_fd (int fd) { eassert (fd < MAXDESC); - eassert (fd <= max_desc); delete_keyboard_wait_descriptor (fd); if (fd_callback_info[fd].flags == 0) @@ -559,7 +558,6 @@ delete_write_fd (int fd) int lim = max_desc; eassert (fd < MAXDESC); - eassert (fd <= max_desc); #ifdef NON_BLOCKING_CONNECT if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0) @@ -6942,7 +6940,6 @@ delete_keyboard_wait_descriptor (int desc) int lim = max_desc; eassert (desc >= 0 && desc < MAXDESC); - eassert (desc <= max_desc); fd_callback_info[desc].flags &= ~(FOR_READ | KEYBOARD_FD | PROCESS_FD); diff --git a/src/systhread.c b/src/systhread.c index b154aba..bde0f02 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -243,37 +243,101 @@ sys_mutex_destroy (sys_mutex_t *mutex) void sys_cond_init (sys_cond_t *cond) { + cond->initialized = false; + cond->wait_count = 0; + /* Auto-reset event for signal. */ cond->events[CONDV_SIGNAL] = CreateEvent (NULL, FALSE, FALSE, NULL); + /* Manual-reset event for broadcast. */ cond->events[CONDV_BROADCAST] = CreateEvent (NULL, TRUE, FALSE, NULL); + if (!cond->events[CONDV_SIGNAL] || !cond->events[CONDV_BROADCAST]) + return; + InitializeCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + cond->initialized = true; } void sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex) { - /* FIXME: This implementation is simple, but incorrect. Stay tuned - for better and more complicated implementation. */ + DWORD wait_result; + bool last_thread_waiting; + + if (!cond->initialized) + return; + + /* Increment the wait count avoiding race conditions. */ + EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + cond->wait_count++; + LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + + /* Release the mutex and wait for either the signal or the broadcast + event. */ LeaveCriticalSection ((LPCRITICAL_SECTION)mutex); - WaitForMultipleObjects (2, cond->events, FALSE, INFINITE); + wait_result = WaitForMultipleObjects (2, cond->events, FALSE, INFINITE); + + /* Decrement the wait count and see if we are the last thread + waiting on the condition variable. */ + EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + cond->wait_count--; + last_thread_waiting = + wait_result == WAIT_OBJECT_0 + CONDV_BROADCAST + && cond->wait_count == 0; + LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + + /* Broadcast uses a manual-reset event, so when the last thread is + released, we must manually reset that event. */ + if (last_thread_waiting) + ResetEvent (cond->events[CONDV_BROADCAST]); + + /* Per the API, re-acquire the mutex. */ EnterCriticalSection ((LPCRITICAL_SECTION)mutex); } void sys_cond_signal (sys_cond_t *cond) { - PulseEvent (cond->events[CONDV_SIGNAL]); + bool threads_waiting; + + if (!cond->initialized) + return; + + EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + threads_waiting = cond->wait_count > 0; + LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + + if (threads_waiting) + SetEvent (cond->events[CONDV_SIGNAL]); } void sys_cond_broadcast (sys_cond_t *cond) { - PulseEvent (cond->events[CONDV_BROADCAST]); + bool threads_waiting; + + if (!cond->initialized) + return; + + EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + threads_waiting = cond->wait_count > 0; + LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); + + if (threads_waiting) + SetEvent (cond->events[CONDV_BROADCAST]); } void sys_cond_destroy (sys_cond_t *cond) { - CloseHandle (cond->events[CONDV_SIGNAL]); - CloseHandle (cond->events[CONDV_BROADCAST]); + if (cond->events[CONDV_SIGNAL]) + CloseHandle (cond->events[CONDV_SIGNAL]); + if (cond->events[CONDV_BROADCAST]) + CloseHandle (cond->events[CONDV_BROADCAST]); + + if (!cond->initialized) + return; + + /* FIXME: What if wait_count is non-zero, i.e. there are still + threads waiting on this condition variable? */ + DeleteCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock); } sys_thread_t @@ -322,7 +386,7 @@ sys_thread_create (sys_thread_t *thread_ptr, const char *name, rule in many places... */ thandle = _beginthread (w32_beginthread_wrapper, stack_size, arg); if (thandle == (uintptr_t)-1L) - return errno; + return 0; /* Kludge alert! We use the Windows thread ID, an unsigned 32-bit number, as the sys_thread_t type, because that ID is the only @@ -337,7 +401,7 @@ sys_thread_create (sys_thread_t *thread_ptr, const char *name, Therefore, we return some more or less arbitrary value of the thread ID from this function. */ *thread_ptr = thandle & 0xFFFFFFFF; - return 0; + return 1; } void diff --git a/src/systhread.h b/src/systhread.h index 5273544..b38fd8f 100644 --- a/src/systhread.h +++ b/src/systhread.h @@ -56,9 +56,13 @@ typedef struct { enum { CONDV_SIGNAL = 0, CONDV_BROADCAST = 1, CONDV_MAX = 2 }; typedef struct { - unsigned waiters_count; - w32thread_critsect waiters_count_lock; + /* Count of threads that are waiting for this condition variable. */ + unsigned wait_count; + /* Critical section to protect changes to the count above. */ + w32thread_critsect wait_count_lock; + /* Handles of events used for signal and broadcast. */ void *events[CONDV_MAX]; + bool initialized; } w32thread_cond_t; typedef w32thread_critsect sys_mutex_t; commit dbe17fefccbff010bbbf6c4d0dccc7b2f3a5e201 Author: Eli Zaretskii Date: Fri Aug 30 17:19:16 2013 +0300 Enable thread support in the MS-Windows build. src/systhread.h (w32thread_critsect, w32thread_cond_t, sys_mutex_t) (sys_cond_t, sys_thread_t) [WINDOWSNT]: New data types. src/systhread.c (sys_mutex_init, sys_mutex_lock, sys_mutex_unlock) (sys_mutex_destroy, sys_cond_init, sys_cond_wait) (sys_cond_signal, sys_cond_broadcast, sys_cond_destroy) (sys_thread_self, sys_thread_equal, w32_beginthread_wrapper) (sys_thread_create, sys_thread_yield) [WINDOWSNT]: New functions. configure.ac (THREADS_ENABLED): Enable threads for MinGW, even if pthreads is not available. diff --git a/ChangeLog b/ChangeLog index 35dbeb6..50a1118 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-08-30 Eli Zaretskii + + * configure.ac (THREADS_ENABLED): Enable threads for MinGW, even + if pthreads is not available. + 2013-08-22 Paul Eggert * configure.ac (EMACS_CONFIG_OPTIONS): Quote systematically (Bug#13274). diff --git a/configure.ac b/configure.ac index 6b22cd0..f8938d0 100644 --- a/configure.ac +++ b/configure.ac @@ -1956,6 +1956,11 @@ if test "$with_threads" = yes; then AC_DEFINE(THREADS_ENABLED, 1, [Define to 1 if you want elisp thread support.]) threads_enabled=yes + elif test "${opsys}" = "mingw32"; then + dnl MinGW can do native Windows threads even without pthreads + AC_DEFINE(THREADS_ENABLED, 1, + [Define to 1 if you want elisp thread support.]) + threads_enabled=yes fi fi AC_MSG_RESULT([$threads_enabled]) diff --git a/src/ChangeLog b/src/ChangeLog index a0682bd..0aef16d 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,14 @@ +2013-08-30 Eli Zaretskii + + * systhread.h (w32thread_critsect, w32thread_cond_t, sys_mutex_t) + (sys_cond_t, sys_thread_t) [WINDOWSNT]: New data types. + + * systhread.c (sys_mutex_init, sys_mutex_lock, sys_mutex_unlock) + (sys_mutex_destroy, sys_cond_init, sys_cond_wait) + (sys_cond_signal, sys_cond_broadcast, sys_cond_destroy) + (sys_thread_self, sys_thread_equal, w32_beginthread_wrapper) + (sys_thread_create, sys_thread_yield) [WINDOWSNT]: New functions. + 2013-08-26 Eli Zaretskii * callproc.c: diff --git a/src/systhread.c b/src/systhread.c index 8c9ec43..b154aba 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -197,6 +197,155 @@ sys_thread_yield (void) sched_yield (); } +#elif defined (WINDOWSNT) + +#include + +/* Cannot include because of the local header by the same + name, sigh. */ +uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *); + +/* Mutexes are implemented as critical sections, because they are + faster than Windows mutex objects (implemented in userspace), and + satisfy the requirements, since we only needto synchronize within a + single process. */ +void +sys_mutex_init (sys_mutex_t *mutex) +{ + InitializeCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_mutex_lock (sys_mutex_t *mutex) +{ + /* FIXME: What happens if the owning thread exits without releasing + the mutex? Accoding to MSDN, the result is undefined behavior. */ + EnterCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_mutex_unlock (sys_mutex_t *mutex) +{ + LeaveCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_mutex_destroy (sys_mutex_t *mutex) +{ + /* FIXME: According to MSDN, deleting a critical session that is + owned by a thread leaves the other threads waiting for the + critical session in an undefined state. Posix docs seems to say + the same about pthread_mutex_destroy. Do we need to protect + against such calamities? */ + DeleteCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_cond_init (sys_cond_t *cond) +{ + cond->events[CONDV_SIGNAL] = CreateEvent (NULL, FALSE, FALSE, NULL); + cond->events[CONDV_BROADCAST] = CreateEvent (NULL, TRUE, FALSE, NULL); +} + +void +sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex) +{ + /* FIXME: This implementation is simple, but incorrect. Stay tuned + for better and more complicated implementation. */ + LeaveCriticalSection ((LPCRITICAL_SECTION)mutex); + WaitForMultipleObjects (2, cond->events, FALSE, INFINITE); + EnterCriticalSection ((LPCRITICAL_SECTION)mutex); +} + +void +sys_cond_signal (sys_cond_t *cond) +{ + PulseEvent (cond->events[CONDV_SIGNAL]); +} + +void +sys_cond_broadcast (sys_cond_t *cond) +{ + PulseEvent (cond->events[CONDV_BROADCAST]); +} + +void +sys_cond_destroy (sys_cond_t *cond) +{ + CloseHandle (cond->events[CONDV_SIGNAL]); + CloseHandle (cond->events[CONDV_BROADCAST]); +} + +sys_thread_t +sys_thread_self (void) +{ + return (sys_thread_t) GetCurrentThreadId (); +} + +int +sys_thread_equal (sys_thread_t one, sys_thread_t two) +{ + return one == two; +} + +static thread_creation_function *thread_start_address; + +static void +w32_beginthread_wrapper (void *arg) +{ + (void)thread_start_address (arg); +} + +int +sys_thread_create (sys_thread_t *thread_ptr, const char *name, + thread_creation_function *func, void *arg) +{ + /* FIXME: Do threads that run Lisp require some minimum amount of + stack? Zero here means each thread will get the same amount as + the main program. On GNU/Linux, it seems like the stack is 2MB + by default, overridden by RLIMIT_STACK at program start time. + Not sure what to do with this. See also the comment in + w32proc"new_child. */ + const unsigned stack_size = 0; + uintptr_t thandle; + + /* _beginthread wants a void function, while we are passed a + function that returns a pointer. So we use a wrapper. */ + thread_start_address = func; + + /* We use _beginthread rather than CreateThread because the former + arranges for the thread handle to be automatically closed when + the thread exits, thus preventing handle leaks and/or the need to + track all the threads and close their handles when they exit. + Also, MSDN seems to imply that code which uses CRT _must_ call + _beginthread, although if that is true, we already violate that + rule in many places... */ + thandle = _beginthread (w32_beginthread_wrapper, stack_size, arg); + if (thandle == (uintptr_t)-1L) + return errno; + + /* Kludge alert! We use the Windows thread ID, an unsigned 32-bit + number, as the sys_thread_t type, because that ID is the only + unique identifier of a thread on Windows. But _beginthread + returns a handle of the thread, and there's no easy way of + getting the thread ID given a handle (GetThreadId is available + only since Vista, so we cannot use it portably). Fortunately, + the value returned by sys_thread_create is not used by its + callers; instead, run_thread, which runs in the context of the + new thread, calls sys_thread_self and uses its return value; + sys_thread_self in this implementation calls GetCurrentThreadId. + Therefore, we return some more or less arbitrary value of the + thread ID from this function. */ + *thread_ptr = thandle & 0xFFFFFFFF; + return 0; +} + +void +sys_thread_yield (void) +{ + Sleep (0); +} + #else #error port me diff --git a/src/systhread.h b/src/systhread.h index eb9cde7..5273544 100644 --- a/src/systhread.h +++ b/src/systhread.h @@ -36,8 +36,42 @@ typedef pthread_t sys_thread_t; #else /* HAVE_PTHREAD */ +#ifdef WINDOWSNT + +/* This header is indirectly included in every source file. We don't + want to include windows.h in every source file, so we repeat + declarations of the few necessary data types here (under different + names, to avoid conflicts with files that do include + windows.h). */ + +typedef struct { + struct _CRITICAL_SECTION_DEBUG *DebugInfo; + long LockCount; + long RecursionCount; + void *OwningThread; + void *LockSemaphore; + unsigned long SpinCount; +} w32thread_critsect; + +enum { CONDV_SIGNAL = 0, CONDV_BROADCAST = 1, CONDV_MAX = 2 }; + +typedef struct { + unsigned waiters_count; + w32thread_critsect waiters_count_lock; + void *events[CONDV_MAX]; +} w32thread_cond_t; + +typedef w32thread_critsect sys_mutex_t; + +typedef w32thread_cond_t sys_cond_t; + +typedef unsigned long sys_thread_t; + +#else /* !WINDOWSNT */ + #error port me +#endif /* WINDOWSNT */ #endif /* HAVE_PTHREAD */ #else /* THREADS_ENABLED */ commit 0e82377a2d9d8f815d2ef4ec09dc914f37fc87ac Author: Tom Tromey Date: Tue Aug 27 13:10:59 2013 -0600 use condition-notify in the docs, not condition-signal diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi index b3a70ee..6237392 100644 --- a/doc/lispref/threads.texi +++ b/doc/lispref/threads.texi @@ -196,12 +196,12 @@ may be spurious notifications. Similarly, the mutex must be held before notifying the condition. The typical, and best, approach is to acquire the mutex, make the -changes associated with this condition, and then signal it: +changes associated with this condition, and then notify it: @example (with-mutex mutex (setq global-variable (some-computation)) - (condition-signal cond-var)) + (condition-notify cond-var)) @end example @defun make-condition-variable mutex &optional name commit c1456e303a4502f637a87681dd623f589c25ed23 Author: Tom Tromey Date: Tue Aug 27 13:07:14 2013 -0600 zap until-condition docs diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi index c846993..b3a70ee 100644 --- a/doc/lispref/threads.texi +++ b/doc/lispref/threads.texi @@ -192,8 +192,7 @@ and waiting on the condition variable. For example: @end example The mutex ensures atomicity, and the loop is for robustness---there -may be spurious notifications. Emacs Lisp provides a macro, -@code{until-condition}, to do this automatically. +may be spurious notifications. Similarly, the mutex must be held before notifying the condition. The typical, and best, approach is to acquire the mutex, make the @@ -251,9 +250,3 @@ Return the name of @var{cond}, as passed to Return the mutex associated with @var{cond}. Note that the associated mutex cannot be changed. @end defun - -@defmac until-condition test cond -Acquire the mutex associated with @var{cond}, and then loop, invoking -the form @var{test}. If @var{test} evaluates to @code{nil}, invoke -@code{condition-wait} on @var{cond}. -@end defmac commit 44586142ad519003abe97e66b3cea0f6bbb020c2 Author: Tom Tromey Date: Tue Aug 27 13:06:17 2013 -0600 zap until-condition diff --git a/lisp/subr.el b/lisp/subr.el index e8bbbb6..17289ef 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4788,20 +4788,6 @@ This is the simplest safe way to acquire and release a mutex." (progn ,@body) (mutex-unlock ,sym))))) -(defmacro until-condition (test condition) - "Wait for the condition variable CONDITION, checking TEST. -Acquire CONDITION's mutex, then check TEST. -If TEST evaluates to nil, repeatedly invoke `condition-wait' on CONDITION. -When CONDITION is signalled, check TEST again. - -This is the simplest safe way to invoke `condition-wait'." - (let ((cond-sym (make-symbol "condition"))) - `(let ((,cond-sym ,condition)) - (with-mutex (condition-mutex ,cond-sym) - (while (not ,test) - (condition-wait ,cond-sym)))))) - - ;;; Misc. (defconst menu-bar-separator '("--") commit 8c46d17826ae89bfa22b5e8048c013c0e3a38b2d Author: Tom Tromey Date: Tue Aug 27 12:57:18 2013 -0600 rename thread-blocker to thread--blocker diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi index 9c33354..c846993 100644 --- a/doc/lispref/threads.texi +++ b/doc/lispref/threads.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Emacs Lisp Reference Manual. -@c Copyright (C) 2012 +@c Copyright (C) 2012, 2013 @c Free Software Foundation, Inc. @c See the file elisp.texi for copying conditions. @node Threads @@ -101,9 +101,10 @@ Return @code{t} if @var{thread} is alive, or @code{nil} if it is not. A thread is alive as long as its function is still executing. @end defun -@defun thread-blocker thread +@defun thread--blocker thread Return the object that @var{thread} is waiting on. This function is -primarily intended for debugging. +primarily intended for debugging, and is given a ``double hyphen'' +name to indicate that. If @var{thread} is blocked in @code{thread-join}, this returns the thread for which it is waiting. diff --git a/src/thread.c b/src/thread.c index 20d0568..39a2151 100644 --- a/src/thread.c +++ b/src/thread.c @@ -804,7 +804,7 @@ DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0, return thread_alive_p (tstate) ? Qt : Qnil; } -DEFUN ("thread-blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0, +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. commit 07efb140348b4a4015c69ed102a5fa216978506f Author: Tom Tromey Date: Tue Aug 27 12:54:38 2013 -0600 remove binding_symbol diff --git a/src/eval.c b/src/eval.c index d36defc..68a3691 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3171,14 +3171,6 @@ let_shadows_global_binding_p (Lisp_Object symbol) return 0; } -static Lisp_Object -binding_symbol (union specbinding *bind) -{ - if (!CONSP (specpdl_symbol (bind))) - return specpdl_symbol (bind); - return XCAR (specpdl_symbol (bind)); -} - void do_specbind (struct Lisp_Symbol *sym, union specbinding *bind, Lisp_Object value) @@ -3209,7 +3201,7 @@ do_specbind (struct Lisp_Symbol *sym, union specbinding *bind, } } - set_internal (binding_symbol (bind), value, Qnil, 1); + set_internal (specpdl_symbol (bind), value, Qnil, 1); break; default: @@ -3350,7 +3342,7 @@ rebind_for_thread_switch (void) Lisp_Object value = specpdl_saved_value (bind); bind->let.saved_value = Qnil; - do_specbind (XSYMBOL (binding_symbol (bind)), bind, value); + do_specbind (XSYMBOL (specpdl_symbol (bind)), bind, value); } } } @@ -3500,7 +3492,7 @@ unbind_for_thread_switch (void) { if (bind->kind >= SPECPDL_LET) { - bind->let.saved_value = find_symbol_value (binding_symbol (bind)); + bind->let.saved_value = find_symbol_value (specpdl_symbol (bind)); do_one_unbind (bind, 0); } } commit c44fedc6039bd96e908f5df25c5816abf7fc87e7 Author: Tom Tromey Date: Tue Aug 27 12:33:04 2013 -0600 fix style of threadp, mutexp, and condition-variable-p diff --git a/src/data.c b/src/data.c index 95cbd47..3763dc8 100644 --- a/src/data.c +++ b/src/data.c @@ -547,8 +547,7 @@ DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0, { if (THREADP (object)) return Qt; - else - return Qnil; + return Qnil; } DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0, @@ -557,8 +556,7 @@ DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0, { if (MUTEXP (object)) return Qt; - else - return Qnil; + return Qnil; } DEFUN ("condition-variable-p", Fcondition_variable_p, Scondition_variable_p, @@ -568,8 +566,7 @@ DEFUN ("condition-variable-p", Fcondition_variable_p, Scondition_variable_p, { if (CONDVARP (object)) return Qt; - else - return Qnil; + return Qnil; } /* Extract and set components of lists. */ commit 6a64a7118d4b0c13789bbe69f2575dd9c1c88524 Author: Tom Tromey Date: Tue Aug 27 12:29:56 2013 -0600 make thread_check_current_buffer return bool diff --git a/src/thread.c b/src/thread.c index ae2212e..20d0568 100644 --- a/src/thread.c +++ b/src/thread.c @@ -882,7 +882,7 @@ DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0, -int +bool thread_check_current_buffer (struct buffer *buffer) { struct thread_state *iter; @@ -893,10 +893,10 @@ thread_check_current_buffer (struct buffer *buffer) continue; if (iter->m_current_buffer == buffer) - return 1; + return true; } - return 0; + return false; } diff --git a/src/thread.h b/src/thread.h index 231c7ac..2b99634 100644 --- a/src/thread.h +++ b/src/thread.h @@ -241,6 +241,6 @@ int thread_select (select_func *func, int max_fds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *timeout, sigset_t *sigmask); -int thread_check_current_buffer (struct buffer *); +bool thread_check_current_buffer (struct buffer *); #endif /* THREAD_H */ commit 5b05b5a6bc5a3293e692d9db969e8a24aa80f1a6 Author: Tom Tromey Date: Tue Aug 27 12:29:05 2013 -0600 add a comment before flush_stack_call_func diff --git a/src/alloc.c b/src/alloc.c index 9b5f295..5de7d38 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -4704,6 +4704,17 @@ mark_stack (char *bottom, char *end) #endif } +/* This is a trampoline function that flushes registers to the stack, + and then calls FUNC. ARG is passed through to FUNC verbatim. + + This function must be called whenever Emacs is about to release the + global interpreter lock. This lets the garbage collector easily + find roots in registers on threads that are not actively running + Lisp. + + It is invalid to run any Lisp code or to allocate any GC memory + from FUNC. */ + void flush_stack_call_func (void (*func) (void *arg), void *arg) { commit 545af8557a68f5f34e74349d6dee9d8319df6f7c Author: Tom Tromey Date: Mon Aug 26 20:09:38 2013 -0600 fix whitespace_regexp warning diff --git a/src/thread.h b/src/thread.h index e77d114..231c7ac 100644 --- a/src/thread.h +++ b/src/thread.h @@ -147,7 +147,9 @@ struct thread_state #define re_syntax_options (current_thread->m_re_syntax_options) /* Regexp to use to replace spaces, or NULL meaning don't. */ - /*re_char*/ unsigned char *m_whitespace_regexp; + /* 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. commit 6e9fb70cdf763da6d264932f14f5a67d354ec38d Author: Eli Zaretskii Date: Mon Aug 26 21:42:11 2013 +0300 Fix MS-Windows build. src/callproc.c: src/emacs.c: src/filelock.c: src/process.c: src/sysdep.c: src/w32.c: Reshuffle Windows-specific headers to avoid errors with redefinition of fd_set etc. src/process.c: Don't use num_pending_connects when NON_BLOCKING_CONNECT is not defined. src/sysselect.h: Move definitions of FD_* macros and of SELECT_TYPE here from w32.h. src/w32proc.c (sys_select): Adjust the argument types to what thread.h expects. nt/inc/sys/socket.h: Include stdint.h. Include sysselect.h instead of w32.h. diff --git a/nt/ChangeLog b/nt/ChangeLog index ebc8230..cf0853c 100644 --- a/nt/ChangeLog +++ b/nt/ChangeLog @@ -1,3 +1,8 @@ +2013-08-26 Eli Zaretskii + + * inc/sys/socket.h: Include stdint.h. Include sysselect.h instead + of w32.h. + 2013-08-25 Vincent Belaïche * configure.bat: Rather than disabling, make configure.bat produce diff --git a/nt/inc/sys/socket.h b/nt/inc/sys/socket.h index 93bf9f9..02a0584 100644 --- a/nt/inc/sys/socket.h +++ b/nt/inc/sys/socket.h @@ -53,6 +53,7 @@ along with GNU Emacs. If not, see . */ #include /* process.c uses uint16_t (from C99) for IPv6, but apparently it is not defined in some versions of mingw and msvc. */ +#include #ifndef UINT16_C typedef unsigned short uint16_t; #endif @@ -73,7 +74,7 @@ typedef unsigned short uint16_t; /* allow us to provide our own version of fd_set */ #define fd_set ws_fd_set -#include "w32.h" +#include "sysselect.h" #endif /* EMACS_CONFIG_H */ #if defined (HAVE_TIMEVAL) && defined (_MSC_VER) diff --git a/src/ChangeLog b/src/ChangeLog index 70d722a..a0682bd 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,22 @@ +2013-08-26 Eli Zaretskii + + * callproc.c: + * emacs.c: + * filelock.c: + * process.c: + * sysdep.c: + * w32.c: Reshuffle Windows-specific headers to avoid errors with + redefinition of fd_set etc. + + * process.c: Don't use num_pending_connects when + NON_BLOCKING_CONNECT is not defined. + + * sysselect.h: Move definitions of FD_* macros and of SELECT_TYPE + here from w32.h. + + * w32proc.c (sys_select): Adjust the argument types to what + thread.h expects. + 2013-08-24 Eli Zaretskii * xdisp.c (get_next_display_element): Don't apply to characters diff --git a/src/callproc.c b/src/callproc.c index d4b4a26..938c2fb 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -26,12 +26,14 @@ along with GNU Emacs. If not, see . */ #include #include +#ifdef WINDOWSNT +#define NOMINMAX +#include /* for fcntl */ +#endif #include "lisp.h" #ifdef WINDOWSNT -#define NOMINMAX -#include /* for fcntl */ #include #include "w32.h" #define _P_NOWAIT 1 /* from process.h */ diff --git a/src/emacs.c b/src/emacs.c index e6d612b..22bca91 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -29,16 +29,18 @@ along with GNU Emacs. If not, see . */ #include -#include "lisp.h" - #ifdef WINDOWSNT #include #include -#include "w32.h" #include "w32heap.h" #endif +#include "lisp.h" + #if defined WINDOWSNT || defined HAVE_NTGUI +#ifdef WINDOWSNT +#include "w32.h" +#endif #include "w32select.h" #include "w32font.h" #include "w32common.h" diff --git a/src/filelock.c b/src/filelock.c index df72eff..5ee5d32 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -36,6 +36,11 @@ along with GNU Emacs. If not, see . */ #include #endif /* __FreeBSD__ */ +#ifdef WINDOWSNT +#include +#include /* for fcntl */ +#endif + #include #include @@ -46,8 +51,6 @@ along with GNU Emacs. If not, see . */ #include "coding.h" #include "systime.h" #ifdef WINDOWSNT -#include -#include /* for fcntl */ #include "w32.h" /* for dostounix_filename */ #endif diff --git a/src/process.c b/src/process.c index 3edc3b4..94ca3d4 100644 --- a/src/process.c +++ b/src/process.c @@ -31,8 +31,6 @@ along with GNU Emacs. If not, see . */ #include #include -#include "lisp.h" - /* Only MS-DOS does not define `subprocesses'. */ #ifdef subprocesses @@ -96,6 +94,8 @@ along with GNU Emacs. If not, see . */ #endif /* subprocesses */ +#include "lisp.h" + #include "systime.h" #include "systty.h" @@ -132,8 +132,7 @@ along with GNU Emacs. If not, see . */ #endif #ifdef WINDOWSNT -extern int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, - EMACS_TIME *, void *); +#include "w32.h" #endif #ifndef SOCK_CLOEXEC @@ -532,7 +531,9 @@ add_non_blocking_write_fd (int fd) 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 @@ -560,11 +561,13 @@ delete_write_fd (int fd) eassert (fd < MAXDESC); eassert (fd <= max_desc); +#ifdef NON_BLOCKING_CONNECT if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0) { if (--num_pending_connects < 0) abort (); } +#endif fd_callback_info[fd].flags &= ~(FOR_WRITE | NON_BLOCKING_CONNECT_FD); if (fd_callback_info[fd].flags == 0) { diff --git a/src/sysdep.c b/src/sysdep.c index 0d73252..0533a5d 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -33,6 +33,17 @@ along with GNU Emacs. If not, see . */ #include #include +#ifdef HAVE_SOCKETS +#include +#include +#endif /* HAVE_SOCKETS */ + +#ifdef TRY_AGAIN +#ifndef HAVE_H_ERRNO +extern int h_errno; +#endif +#endif /* TRY_AGAIN */ + #include "lisp.h" #include "sysselect.h" #include "blockinput.h" @@ -58,7 +69,7 @@ along with GNU Emacs. If not, see . */ #ifndef STDERR_FILENO #define STDERR_FILENO fileno(GetStdHandle(STD_ERROR_HANDLE)) #endif -#include +#include "w32.h" #endif /* not WINDOWSNT */ #include @@ -1325,17 +1336,6 @@ setup_pty (int fd) } #endif /* HAVE_PTYS */ -#ifdef HAVE_SOCKETS -#include -#include -#endif /* HAVE_SOCKETS */ - -#ifdef TRY_AGAIN -#ifndef HAVE_H_ERRNO -extern int h_errno; -#endif -#endif /* TRY_AGAIN */ - void init_system_name (void) { diff --git a/src/sysselect.h b/src/sysselect.h index 0a4f7e3..244f0f7 100644 --- a/src/sysselect.h +++ b/src/sysselect.h @@ -16,14 +16,47 @@ 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 EMACS_SYSSELECT_H +#define EMACS_SYSSELECT_H + #ifndef DOS_NT #include #endif -/* The w32 build defines select stuff in w32.h, which is included - where w32 needs it, but not where sysselect.h is included. The w32 - definitions in w32.h are incompatible with the below. */ -#ifndef WINDOWSNT +#ifdef WINDOWSNT + +/* File descriptor set emulation. */ + +/* MSVC runtime library has limit of 64 descriptors by default */ +#define FD_SETSIZE 64 +typedef struct { + unsigned int bits[FD_SETSIZE / 32]; +} fd_set; + +/* standard access macros */ +#define FD_SET(n, p) \ + do { \ + if ((n) < FD_SETSIZE) { \ + (p)->bits[(n)/32] |= (1 << (n)%32); \ + } \ + } while (0) +#define FD_CLR(n, p) \ + do { \ + if ((n) < FD_SETSIZE) { \ + (p)->bits[(n)/32] &= ~(1 << (n)%32); \ + } \ + } while (0) +#define FD_ISSET(n, p) ((n) < FD_SETSIZE ? ((p)->bits[(n)/32] & (1 << (n)%32)) : 0) +#define FD_ZERO(p) memset((p), 0, sizeof(fd_set)) + +#define SELECT_TYPE fd_set + +#include "systime.h" +extern int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, + EMACS_TIME *, sigset_t *); + +#else /* not WINDOWSNT */ + #ifdef FD_SET #ifdef FD_SETSIZE #define MAXDESC FD_SETSIZE @@ -50,3 +83,5 @@ along with GNU Emacs. If not, see . */ #ifdef MSDOS #define pselect sys_select #endif + +#endif /* EMACS_SYSSELECT_H */ diff --git a/src/w32.c b/src/w32.c index 7f9b96a..631405f 100644 --- a/src/w32.c +++ b/src/w32.c @@ -39,6 +39,8 @@ along with GNU Emacs. If not, see . */ #include #include /* for _mbspbrk, _mbslwr, _mbsrchr, ... */ +#include + #undef access #undef chdir #undef chmod @@ -70,7 +72,7 @@ along with GNU Emacs. If not, see . */ #include /* MinGW64 (_W64) defines these in its _mingw.h. */ -#if defined(__GNUC__) && !defined(_W64) +#if !defined(_ANONYMOUS_UNION) && !defined(_ANONYMOUS_STRUCT) #define _ANONYMOUS_UNION #define _ANONYMOUS_STRUCT #endif @@ -197,7 +199,6 @@ typedef struct _REPARSE_DATA_BUFFER { #endif /* TCP connection support. */ -#include #undef socket #undef bind #undef connect @@ -247,7 +248,7 @@ static BOOL WINAPI revert_to_self (void); extern int sys_access (const char *, int); extern void *e_malloc (size_t); extern int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, - EMACS_TIME *, void *); + EMACS_TIME *, sigset_t *); extern int sys_dup (int); diff --git a/src/w32.h b/src/w32.h index 9c1f1ef..c65e40c 100644 --- a/src/w32.h +++ b/src/w32.h @@ -25,33 +25,6 @@ along with GNU Emacs. If not, see . */ #include - -/* File descriptor set emulation. */ - -/* MSVC runtime library has limit of 64 descriptors by default */ -#define FD_SETSIZE 64 -typedef struct { - unsigned int bits[FD_SETSIZE / 32]; -} fd_set; - -/* standard access macros */ -#define FD_SET(n, p) \ - do { \ - if ((n) < FD_SETSIZE) { \ - (p)->bits[(n)/32] |= (1 << (n)%32); \ - } \ - } while (0) -#define FD_CLR(n, p) \ - do { \ - if ((n) < FD_SETSIZE) { \ - (p)->bits[(n)/32] &= ~(1 << (n)%32); \ - } \ - } while (0) -#define FD_ISSET(n, p) ((n) < FD_SETSIZE ? ((p)->bits[(n)/32] & (1 << (n)%32)) : 0) -#define FD_ZERO(p) memset((p), 0, sizeof(fd_set)) - -#define SELECT_TYPE fd_set - /* ------------------------------------------------------------------------- */ /* child_process.status values */ diff --git a/src/w32proc.c b/src/w32proc.c index 8458938..599cb3c 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -1916,7 +1916,7 @@ extern int proc_buffered_char[]; int sys_select (int nfds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, - EMACS_TIME *timeout, void *ignored) + EMACS_TIME *timeout, sigset_t *ignored) { SELECT_TYPE orfds; DWORD timeout_ms, start_time; commit c160274456eb7bb09776b888f5274933f2ec2399 Author: Tom Tromey Date: Mon Aug 26 08:53:26 2013 -0600 use record_unwind_protect_void, avoid warning diff --git a/src/thread.c b/src/thread.c index 59845b6..ae2212e 100644 --- a/src/thread.c +++ b/src/thread.c @@ -220,11 +220,10 @@ mutex_lock_callback (void *arg) post_acquire_global_lock (self); } -static Lisp_Object -do_unwind_mutex_lock (Lisp_Object ignore) +static void +do_unwind_mutex_lock (void) { current_thread->event_object = Qnil; - return Qnil; } DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0, @@ -244,7 +243,7 @@ Note that calls to `mutex-lock' and `mutex-unlock' must be paired. */) lmutex = XMUTEX (mutex); current_thread->event_object = mutex; - record_unwind_protect (do_unwind_mutex_lock, Qnil); + record_unwind_protect_void (do_unwind_mutex_lock); flush_stack_call_func (mutex_lock_callback, lmutex); return unbind_to (count, Qnil); } commit 2ee7755c8d35aba1d598c9baa910bd5af228f095 Author: Tom Tromey Date: Mon Aug 26 08:46:30 2013 -0600 implement --enable-threads and a thread-less mode diff --git a/configure.ac b/configure.ac index bbd799c..6b22cd0 100644 --- a/configure.ac +++ b/configure.ac @@ -237,6 +237,7 @@ OPTION_DEFAULT_ON([gsettings],[don't compile with GSettings support]) 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_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)])], @@ -1948,6 +1949,17 @@ AC_SUBST([LIB_PTHREAD]) AC_CHECK_LIB(pthreads, cma_open) +AC_MSG_CHECKING([for thread support]) +threads_enabled=no +if test "$with_threads" = yes; then + if test "$HAVE_PTHREAD" = yes; then + AC_DEFINE(THREADS_ENABLED, 1, + [Define to 1 if you want elisp thread support.]) + threads_enabled=yes + fi +fi +AC_MSG_RESULT([$threads_enabled]) + ## Note: when using cpp in s/aix4.2.h, this definition depended on ## HAVE_LIBPTHREADS. That was not defined earlier in configure when ## the system file was sourced. Hence the value of LIBS_SYSTEM @@ -4843,6 +4855,7 @@ echo " Does Emacs use -lxft? ${HAVE_XFT}" echo " Does Emacs directly use zlib? ${HAVE_ZLIB}" echo " Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS}" +echo " Does Emacs have threading support in elisp? ${threads_enabled}" echo if test -n "${EMACSDATA}"; then diff --git a/src/systhread.c b/src/systhread.c index ab64752..8c9ec43 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -1,5 +1,5 @@ /* System thread definitions - Copyright (C) 2012 Free Software Foundation, Inc. + Copyright (C) 2012, 2013 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -20,7 +20,80 @@ along with GNU Emacs. If not, see . */ #include #include "lisp.h" -#ifdef HAVE_PTHREAD +#ifndef THREADS_ENABLED + +void +sys_mutex_init (sys_mutex_t *m) +{ + *m = 0; +} + +void +sys_mutex_lock (sys_mutex_t *m) +{ +} + +void +sys_mutex_unlock (sys_mutex_t *m) +{ +} + +void +sys_mutex_destroy (sys_mutex_t *m) +{ +} + +void +sys_cond_init (sys_cond_t *c) +{ + *c = 0; +} + +void +sys_cond_wait (sys_cond_t *c, sys_mutex_t *m) +{ +} + +void +sys_cond_signal (sys_cond_t *c) +{ +} + +void +sys_cond_broadcast (sys_cond_t *c) +{ +} + +void +sys_cond_destroy (sys_cond_t *c) +{ +} + +sys_thread_t +sys_thread_self (void) +{ + return 0; +} + +int +sys_thread_equal (sys_thread_t x, sys_thread_t y) +{ + return x == y; +} + +int +sys_thread_create (sys_thread_t *t, const char *name, + thread_creation_function *func, void *datum) +{ + return 0; +} + +void +sys_thread_yield (void) +{ +} + +#elif defined (HAVE_PTHREAD) #include diff --git a/src/systhread.h b/src/systhread.h index bbd242a..eb9cde7 100644 --- a/src/systhread.h +++ b/src/systhread.h @@ -1,5 +1,5 @@ /* System thread definitions - Copyright (C) 2012 Free Software Foundation, Inc. + Copyright (C) 2012, 2013 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -19,6 +19,8 @@ along with GNU Emacs. If not, see . */ #ifndef SYSTHREAD_H #define SYSTHREAD_H +#ifdef THREADS_ENABLED + #ifdef HAVE_PTHREAD #include @@ -32,11 +34,20 @@ typedef pthread_cond_t sys_cond_t; /* A system thread. */ typedef pthread_t sys_thread_t; -#else +#else /* HAVE_PTHREAD */ #error port me -#endif +#endif /* HAVE_PTHREAD */ + +#else /* THREADS_ENABLED */ + +/* For the no-threads case we can simply use dummy definitions. */ +typedef int sys_mutex_t; +typedef int sys_cond_t; +typedef int sys_thread_t; + +#endif /* THREADS_ENABLED */ typedef void *(thread_creation_function) (void *); diff --git a/src/thread.c b/src/thread.c index 4c6b654..59845b6 100644 --- a/src/thread.c +++ b/src/thread.c @@ -937,24 +937,29 @@ init_threads (void) void syms_of_threads (void) { - 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); +#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); + } Qthreadp = intern_c_string ("threadp"); staticpro (&Qthreadp); commit 793ea5055aea85ff9227e1bf0c84ab37edba7201 Merge: 1ce4c63 e687aa3 Author: Tom Tromey Date: Sun Aug 25 14:25:59 2013 -0600 merge from trunk commit 1ce4c6398ea453a66f6943552b0ec866a690e9b1 Author: Tom Tromey Date: Mon Aug 19 22:13:47 2013 -0600 fix up some merge errors in process.c remove a dead function clean up a fixme I added in create_pty during the merge diff --git a/src/process.c b/src/process.c index 91483e5..1d1741d 100644 --- a/src/process.c +++ b/src/process.c @@ -550,22 +550,6 @@ recompute_max_desc (void) } } -/* FD is no longer an input descriptor; update max_input_desc accordingly. */ - -static void -delete_input_desc (int fd) -{ - if (fd == max_input_desc) - { - do - fd--; - while (0 <= fd && ! (FD_ISSET (fd, &input_wait_mask) - || FD_ISSET (fd, &write_mask))); - - max_input_desc = fd; - } -} - /* Stop monitoring file descriptor FD for when write is possible. */ void @@ -2155,7 +2139,7 @@ create_pty (Lisp_Object process) pset_status (p, Qrun); setup_process_coding_systems (process); - fixme; + add_non_keyboard_read_fd (pty_fd); pset_tty_name (p, build_string (pty_name)); } commit 6d75555c5cc3d2a629646cee7629e67530fa7a36 Merge: cc231cb 8c2f38a Author: Tom Tromey Date: Mon Aug 19 21:53:07 2013 -0600 merge from trunk commit cc231cbe45d27a1906d268fb72d3b4105a2e9c65 Merge: b34a529 fec9206 Author: Tom Tromey Date: Fri Jul 26 14:02:53 2013 -0600 merge from trunk commit b34a529f177a6ea32da5cb1254f91bf9d71838db Merge: e6f6307 5e301d7 Author: Tom Tromey Date: Fri Jul 12 18:44:13 2013 -0600 Merge from trunk commit e6f63071a3f7721f55220514b6d9a8ee8c1232d8 Author: Tom Tromey Date: Thu Jul 11 17:27:28 2013 -0600 Use thread_alive_p in a couple more spots diff --git a/src/thread.c b/src/thread.c index c7fface..4c6b654 100644 --- a/src/thread.c +++ b/src/thread.c @@ -832,7 +832,7 @@ thread_join_callback (void *arg) XSETTHREAD (thread, tstate); self->event_object = thread; self->wait_condvar = &tstate->thread_condvar; - while (tstate->m_specpdl != NULL && NILP (self->error_symbol)) + while (thread_alive_p (tstate) && NILP (self->error_symbol)) sys_cond_wait (self->wait_condvar, &global_lock); self->wait_condvar = NULL; @@ -854,7 +854,7 @@ It is an error for a thread to try to join itself. */) if (tstate == current_thread) error ("cannot join current thread"); - if (tstate->m_specpdl != NULL) + if (thread_alive_p (tstate)) flush_stack_call_func (thread_join_callback, tstate); return Qnil; commit 65ddc9fdcdda92707953501fcd0a0e271be9df55 Author: Tom Tromey Date: Sun Jul 7 14:30:31 2013 -0600 fix xfree bug in run_thread this fixes run_thread to account for the dummy slot in specpdl diff --git a/src/thread.c b/src/thread.c index a8e79e8..c7fface 100644 --- a/src/thread.c +++ b/src/thread.c @@ -646,7 +646,7 @@ run_thread (void *state) update_processes_for_thread_death (Fcurrent_thread ()); - xfree (self->m_specpdl); + xfree (self->m_specpdl - 1); self->m_specpdl = NULL; self->m_specpdl_ptr = NULL; self->m_specpdl_size = 0; commit 6dacdad5fcb278e5a16b38bb81786aac9ca27be4 Merge: 0a6f2ff 219afb8 Author: Tom Tromey Date: Sat Jul 6 23:18:58 2013 -0600 merge from trunk this merges frmo trunk and fixes various build issues. this needed a few ugly tweaks. this hangs in "make check" now commit 0a6f2ff0c8ceb29703e76cddd46ea3f176dd873a Author: Tom Tromey Date: Sat Jul 6 14:31:16 2013 -0600 add assertion to flush_stack_call_func functions called via flush_stack_call_func are assumed to return with the global lock held again, and with current_thread reset. this assertion verifies part of this diff --git a/src/alloc.c b/src/alloc.c index b5885bd..d62b671 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -4649,6 +4649,7 @@ void flush_stack_call_func (void (*func) (void *arg), void *arg) { void *end; + struct thread_state *self = current_thread; #ifdef HAVE___BUILTIN_UNWIND_INIT /* Force callee-saved registers and register windows onto the stack. @@ -4702,8 +4703,10 @@ flush_stack_call_func (void (*func) (void *arg), void *arg) #endif /* not GC_SAVE_REGISTERS_ON_STACK */ #endif /* not HAVE___BUILTIN_UNWIND_INIT */ - current_thread->stack_top = end; + self->stack_top = end; (*func) (arg); + + eassert (current_thread == self); } #endif /* GC_MARK_STACK != 0 */ commit 32ca162e99da7767a0c1fde6b4aa9fb746680ec4 Author: Tom Tromey Date: Sat Jul 6 14:26:36 2013 -0600 call init_primary_thread from init_threads diff --git a/src/thread.c b/src/thread.c index 99ca21b..21f74b7 100644 --- a/src/thread.c +++ b/src/thread.c @@ -924,6 +924,7 @@ init_threads_once (void) void init_threads (void) { + init_primary_thread (); sys_cond_init (&primary_thread.thread_condvar); sys_mutex_init (&global_lock); sys_mutex_lock (&global_lock); commit 3bf8db999bd8857a1f8ae10dafe09182f68be58f Author: Tom Tromey Date: Thu Jul 4 20:02:20 2013 -0600 avoid SAFE_ALLOCA avoid SAFE_ALLOCA in xgselect.c. in this code it is just as easy to always use malloc; and it avoids thread-switching problems, as the safe-alloca stuff implicitly refers to the current thread diff --git a/src/xgselect.c b/src/xgselect.c index 4d90298..15ee59d 100644 --- a/src/xgselect.c +++ b/src/xgselect.c @@ -40,8 +40,7 @@ xg_select (int fds_lim, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, GPollFD *gfds = gfds_buf; int gfds_size = sizeof gfds_buf / sizeof *gfds_buf; int n_gfds, retval = 0, our_fds = 0, max_fds = fds_lim - 1; - int i, nfds, tmo_in_millisec; - USE_SAFE_ALLOCA; + int i, nfds, tmo_in_millisec, must_free = 0; /* Do not try to optimize with an initial check with g_main_context_pending and a call to pselect if it returns false. If Gdk has a timeout for 0.01 @@ -60,7 +59,8 @@ xg_select (int fds_lim, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, gfds, gfds_size); if (gfds_size < n_gfds) { - SAFE_NALLOCA (gfds, sizeof *gfds, n_gfds); + gfds = xnmalloc (n_gfds, sizeof *gfds); + must_free = 1; gfds_size = n_gfds; n_gfds = g_main_context_query (context, G_PRIORITY_LOW, &tmo_in_millisec, gfds, gfds_size); @@ -81,7 +81,8 @@ xg_select (int fds_lim, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, } } - SAFE_FREE (); + if (must_free) + xfree (gfds); if (tmo_in_millisec >= 0) { commit 9db4b98e1356549d999b342bd449f916c27fea8a Author: Tom Tromey Date: Thu Jul 4 20:00:54 2013 -0600 avoid current_thread sometimes this tweaks thread.c to use 'self' instead of current_thread in a couple spots. this is clearer and more robust diff --git a/src/thread.c b/src/thread.c index 8a81a10..99ca21b 100644 --- a/src/thread.c +++ b/src/thread.c @@ -337,7 +337,7 @@ condition_wait_callback (void *arg) Lisp_Object cond; XSETCONDVAR (cond, cvar); - current_thread->event_object = cond; + 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. */ @@ -348,7 +348,7 @@ condition_wait_callback (void *arg) self->wait_condvar = NULL; } lisp_mutex_lock (&mutex->mutex, saved_count); - current_thread->event_object = Qnil; + self->event_object = Qnil; post_acquire_global_lock (self); } @@ -614,6 +614,7 @@ static Lisp_Object invoke_thread_function (void) { Lisp_Object iter; + volatile struct thread_state *self = current_thread; int count = SPECPDL_INDEX (); commit e7b4d03f5a74b16c924079b75f5b0617c9ee7add Author: Tom Tromey Date: Thu Jul 4 19:48:59 2013 -0600 initialize saved_value initialize the saved_value field in all needed cases also, add an assertion to do_one_unbind diff --git a/src/eval.c b/src/eval.c index 3f7be81..37ea81b 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3118,6 +3118,7 @@ specbind (Lisp_Object symbol, Lisp_Object value) specpdl_ptr->v.let.symbol = symbol; specpdl_ptr->v.let.old_value = ovalue; specpdl_ptr->v.let.where = Fcurrent_buffer (); + specpdl_ptr->v.let.saved_value = Qnil; eassert (sym->redirect != SYMBOL_LOCALIZED || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ()))); @@ -3184,6 +3185,7 @@ rebind_for_thread_switch (void) static void do_one_unbind (struct specbinding *this_binding, int unwinding) { + eassert (unwinding || this_binding->kind >= SPECPDL_LET); switch (this_binding->kind) { case SPECPDL_UNWIND: commit b09859f771fb46a2248198f45ae40712e4c7dd8a Author: Tom Tromey Date: Thu Jul 4 14:18:15 2013 -0600 fix buglet in test case diff --git a/test/automated/threads.el b/test/automated/threads.el index db6aa41..c65b642 100644 --- a/test/automated/threads.el +++ b/test/automated/threads.el @@ -1,6 +1,6 @@ ;;; threads.el --- tests for threads. -;; Copyright (C) 2012 Free Software Foundation, Inc. +;; Copyright (C) 2012, 2013 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -85,7 +85,7 @@ "simple test of threads and let bindings" (should (progn - (setq threads-test-binding nil) + (setq threads-test-global nil) (make-thread #'threads-test-thread2) (while (not threads-test-global) (thread-yield)) commit 2efa60a37de1602f2c867010b1eddda92211c7ad Author: Tom Tromey Date: Wed Jul 3 22:00:43 2013 -0600 unlink thread later unlink thread from global list later also remove some unnecessary destruction code diff --git a/src/thread.c b/src/thread.c index 3619684..8a81a10 100644 --- a/src/thread.c +++ b/src/thread.c @@ -645,17 +645,6 @@ run_thread (void *state) update_processes_for_thread_death (Fcurrent_thread ()); - /* Unlink this thread from the list of all threads. */ - for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread) - ; - *iter = (*iter)->next_thread; - - self->m_last_thing_searched = Qnil; - self->m_saved_last_thing_searched = Qnil; - self->name = Qnil; - self->function = Qnil; - self->error_symbol = Qnil; - self->error_data = Qnil; xfree (self->m_specpdl); self->m_specpdl = NULL; self->m_specpdl_ptr = NULL; @@ -664,6 +653,14 @@ run_thread (void *state) 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; commit 39d7c9d51bf0a5d545de37ee668c5cbc17b79589 Author: Tom Tromey Date: Wed Jul 3 16:20:07 2013 -0600 introduce thread_alive_p macro This introduces the thread_alive_p macro and changes thread-alive-p to use it. This is a minor cleanup. It also changes all-threads to ignore dead threads. diff --git a/src/thread.c b/src/thread.c index 0235944..3619684 100644 --- a/src/thread.c +++ b/src/thread.c @@ -37,6 +37,12 @@ Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep; +/* 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) { @@ -796,9 +802,7 @@ DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0, CHECK_THREAD (thread); tstate = XTHREAD (thread); - /* m_specpdl is set when the thread is created and cleared when the - thread dies. */ - return tstate->m_specpdl == NULL ? Qnil : Qt; + return thread_alive_p (tstate) ? Qt : Qnil; } DEFUN ("thread-blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0, @@ -865,10 +869,13 @@ DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0, for (iter = all_threads; iter; iter = iter->next_thread) { - Lisp_Object thread; + if (thread_alive_p (iter)) + { + Lisp_Object thread; - XSETTHREAD (thread, iter); - result = Fcons (thread, result); + XSETTHREAD (thread, iter); + result = Fcons (thread, result); + } } return result; commit c60685a8c4f1a7cc15c8fd2cd53fe9bb27245baf Author: Tom Tromey Date: Wed Jul 3 13:42:31 2013 -0600 Don't call unbind_for_thread_switch in run_thread This removes the call to unbind_for_thread_switch from run_thread. This isn't necessary because acquire_global_lock does it properly. diff --git a/src/thread.c b/src/thread.c index 8f58faf..0235944 100644 --- a/src/thread.c +++ b/src/thread.c @@ -637,8 +637,6 @@ run_thread (void *state) /* It might be nice to do something with errors here. */ internal_condition_case (invoke_thread_function, Qt, do_nothing); - unbind_for_thread_switch (); - update_processes_for_thread_death (Fcurrent_thread ()); /* Unlink this thread from the list of all threads. */ commit 1d10d048003619f4e2d396a03274adad0dec78ba Author: Tom Tromey Date: Wed Jul 3 13:12:10 2013 -0600 remove unused field from struct thread_state diff --git a/src/thread.h b/src/thread.h index 9f0eead..e43b0a3 100644 --- a/src/thread.h +++ b/src/thread.h @@ -99,12 +99,6 @@ struct thread_state struct specbinding *m_specpdl_ptr; #define specpdl_ptr (current_thread->m_specpdl_ptr) - /* Pointer to the first "saved" element in specpdl. When this - thread is swapped out, the current values of all specpdl bindings - are pushed onto the specpdl; then these are popped again when - switching back to this thread. */ - struct specbinding *m_saved_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) commit fbadec0d00820939ccac548aa54ed67a540bdd80 Author: Tom Tromey Date: Wed Jul 3 12:19:11 2013 -0600 Fix a comment. diff --git a/src/lisp.h b/src/lisp.h index 1892c5f..7a8823e 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2258,8 +2258,8 @@ struct specbinding struct { /* `where' is not used in the case of SPECPDL_LET. */ Lisp_Object symbol, old_value, where; - /* Normally this is unused; but it is to the symbol's current - value when a thread is swapped out. */ + /* Normally this is unused; but it is set to the symbol's + current value when a thread is swapped out. */ Lisp_Object saved_value; } let; struct { commit 5ccb7e7b1ea2ca7f6e45d00d839e19f22cc961da Merge: 313dfb6 94fa6ec Author: Tom Tromey Date: Thu Jun 13 11:29:06 2013 -0600 merge from trunk commit 313dfb6277b3e1ef28c7bb76e776f10168e3f0a3 Author: Tom Tromey Date: Thu Jun 6 13:18:05 2013 -0600 fix a few latent issues in the thread patch * we called unbind_for_thread_switch unconditionally, but this is wrong if the previous thread exited * likewise, exiting a thread should clear current_thread * redundant assignment in run_thread * clean up init_threads - no need to re-init the primary thread This patch still sometimes causes weird hangs in "make check". However, I think that is a kernel bug, since Emacs enters the zombie state but its parent process hangs in wait. This shouldn't happen. diff --git a/src/thread.c b/src/thread.c index 1d282c3..8f58faf 100644 --- a/src/thread.c +++ b/src/thread.c @@ -52,7 +52,11 @@ post_acquire_global_lock (struct thread_state *self) if (self != current_thread) { - unbind_for_thread_switch (); + /* CURRENT_THREAD is NULL if the previously current thread + exited. In this case, there is no reason to unbind, and + trying will crash. */ + if (current_thread != NULL) + unbind_for_thread_switch (); current_thread = self; rebind_for_thread_switch (); } @@ -625,7 +629,7 @@ run_thread (void *state) struct thread_state **iter; self->m_stack_bottom = &stack_pos; - self->stack_top = self->m_stack_bottom = &stack_pos; + self->stack_top = &stack_pos; self->thread_id = sys_thread_self (); acquire_global_lock (self); @@ -653,6 +657,7 @@ run_thread (void *state) self->m_specpdl_ptr = NULL; self->m_specpdl_size = 0; + current_thread = NULL; sys_cond_broadcast (&self->thread_condvar); release_global_lock (); @@ -905,8 +910,6 @@ init_primary_thread (void) primary_thread.error_symbol = Qnil; primary_thread.error_data = Qnil; primary_thread.event_object = Qnil; - - sys_cond_init (&primary_thread.thread_condvar); } void @@ -918,10 +921,11 @@ init_threads_once (void) 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 commit ac70709c2ad3fa97e7553adfb4958c0a08faa40b Author: Tom Tromey Date: Mon Jun 3 19:36:49 2013 -0600 update eval.c to make it build again after the merge diff --git a/src/eval.c b/src/eval.c index be9de93..7520164 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3014,11 +3014,11 @@ let_shadows_global_binding_p (Lisp_Object symbol) } static Lisp_Object -binding_symbol (const struct specbinding *bind) +binding_symbol (struct specbinding *bind) { - if (!CONSP (bind->symbol)) - return bind->symbol; - return XCAR (bind->symbol); + if (!CONSP (specpdl_symbol (bind))) + return specpdl_symbol (bind); + return XCAR (specpdl_symbol (bind)); } void @@ -3031,22 +3031,22 @@ do_specbind (struct Lisp_Symbol *sym, struct specbinding *bind, if (!sym->constant) SET_SYMBOL_VAL (sym, value); else - set_internal (bind->symbol, value, Qnil, 1); + set_internal (specpdl_symbol (bind), value, Qnil, 1); break; case SYMBOL_LOCALIZED: case SYMBOL_FORWARDED: if ((sym->redirect == SYMBOL_LOCALIZED || BUFFER_OBJFWDP (SYMBOL_FWD (sym))) - && CONSP (bind->symbol)) + && CONSP (specpdl_symbol (bind))) { Lisp_Object where; - where = XCAR (XCDR (bind->symbol)); + where = XCAR (XCDR (specpdl_symbol (bind))); if (NILP (where) && sym->redirect == SYMBOL_FORWARDED) { - Fset_default (XCAR (bind->symbol), value); + Fset_default (XCAR (specpdl_symbol (bind)), value); return; } } @@ -3164,16 +3164,16 @@ rebind_for_thread_switch (void) { if (bind->kind >= SPECPDL_LET) { - Lisp_Object value = bind->saved_value; + Lisp_Object value = specpdl_saved_value (bind); - bind->saved_value = Qnil; + bind->v.let.saved_value = Qnil; do_specbind (XSYMBOL (binding_symbol (bind)), bind, value); } } } static void -do_one_unbind (const struct specbinding *this_binding, int unwinding) +do_one_unbind (struct specbinding *this_binding, int unwinding) { switch (this_binding->kind) { @@ -3260,7 +3260,7 @@ unbind_for_thread_switch (void) { if (bind->kind >= SPECPDL_LET) { - bind->saved_value = find_symbol_value (binding_symbol (bind)); + bind->v.let.saved_value = find_symbol_value (binding_symbol (bind)); do_one_unbind (bind, 0); } } commit 68359abba96d7ec4db8aab3d3dd9cf1105c3bab5 Merge: cbcba8c e2d8a6f Author: Tom Tromey Date: Mon Jun 3 12:25:05 2013 -0600 merge from trunk; clean up some issues commit cbcba8ce7f980b01c18c0fd561ef6687b1361507 Author: Tom Tromey Date: Mon Mar 18 08:48:53 2013 -0600 don't let kill-buffer kill a buffer if it is current in any thread diff --git a/src/buffer.c b/src/buffer.c index 4d24f97..b7b471d 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -1726,6 +1726,9 @@ cleaning up all windows currently displaying the buffer to be killed. */) if (!BUFFER_LIVE_P (b)) return Qnil; + if (thread_check_current_buffer (b)) + return Qnil; + /* Query if the buffer is still modified. */ if (INTERACTIVE && !NILP (BVAR (b, filename)) && BUF_MODIFF (b) > BUF_SAVE_MODIFF (b)) diff --git a/src/thread.c b/src/thread.c index 551f3de..7de260e 100644 --- a/src/thread.c +++ b/src/thread.c @@ -881,6 +881,25 @@ DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0, +int +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 1; + } + + return 0; +} + + + static void init_primary_thread (void) { diff --git a/src/thread.h b/src/thread.h index 97bdb2c..47fa87c 100644 --- a/src/thread.h +++ b/src/thread.h @@ -248,4 +248,6 @@ int thread_select (select_func *func, int max_fds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *timeout, sigset_t *sigmask); +int thread_check_current_buffer (struct buffer *); + #endif /* THREAD_H */ commit dad8121b0e4438e68b23d388585f703e75951337 Author: Tom Tromey Date: Sun Mar 17 19:49:39 2013 -0600 fix process bugs Fix some process-related bugs, mostly thinkos from the conversion to recording fd state as flags. This now passes the test suite without hanging. diff --git a/src/process.c b/src/process.c index 044e0c5..e8e7a2b 100644 --- a/src/process.c +++ b/src/process.c @@ -266,11 +266,8 @@ static void exec_sentinel (Lisp_Object proc, Lisp_Object reason); static int num_pending_connects; #endif /* NON_BLOCKING_CONNECT */ -/* The largest descriptor currently in use for a process object. */ -static int max_process_desc; - /* The largest descriptor currently in use for input. */ -static int max_input_desc; +static int max_desc; /* Indexed by descriptor, gives the process (if any) for that descriptor */ static Lisp_Object chan_process[MAXDESC]; @@ -436,17 +433,17 @@ add_read_fd (int fd, fd_callback func, void *data) fd_callback_info[fd].data = data; } -void +static void add_non_keyboard_read_fd (int fd) { eassert (fd >= 0 && fd < MAXDESC); eassert (fd_callback_info[fd].func == NULL); fd_callback_info[fd].flags |= FOR_READ; - if (fd > max_input_desc) - max_input_desc = fd; + if (fd > max_desc) + max_desc = fd; } -void +static void add_process_read_fd (int fd) { add_non_keyboard_read_fd (fd); @@ -459,6 +456,7 @@ void delete_read_fd (int fd) { eassert (fd < MAXDESC); + eassert (fd <= max_desc); delete_keyboard_wait_descriptor (fd); if (fd_callback_info[fd].flags == 0) @@ -475,34 +473,51 @@ void add_write_fd (int fd, fd_callback func, void *data) { eassert (fd < MAXDESC); - if (fd > max_input_desc) - max_input_desc = fd; + if (fd > max_desc) + max_desc = fd; fd_callback_info[fd].func = func; fd_callback_info[fd].data = data; fd_callback_info[fd].flags |= FOR_WRITE; } -void +static void add_non_blocking_write_fd (int fd) { eassert (fd >= 0 && fd < MAXDESC); eassert (fd_callback_info[fd].func == NULL); fd_callback_info[fd].flags |= FOR_WRITE | NON_BLOCKING_CONNECT_FD; - if (fd > max_input_desc) - max_input_desc = fd; + if (fd > max_desc) + max_desc = fd; ++num_pending_connects; } +static void +recompute_max_desc (void) +{ + int fd; + + for (fd = max_desc; fd >= 0; --fd) + { + if (fd_callback_info[fd].flags != 0) + { + max_desc = fd; + break; + } + } +} + /* Stop monitoring file descriptor FD for when write is possible. */ void delete_write_fd (int fd) { - int lim = max_input_desc; + int lim = max_desc; eassert (fd < MAXDESC); + eassert (fd <= max_desc); + if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0) { if (--num_pending_connects < 0) @@ -514,17 +529,8 @@ delete_write_fd (int fd) fd_callback_info[fd].func = 0; fd_callback_info[fd].data = 0; - if (fd == max_input_desc) - { - for (fd = max_input_desc; fd >= 0; --fd) - { - if (fd_callback_info[fd].flags != 0) - { - max_input_desc = fd; - break; - } - } - } + if (fd == max_desc) + recompute_max_desc (); } } @@ -534,7 +540,7 @@ compute_input_wait_mask (SELECT_TYPE *mask) int fd; FD_ZERO (mask); - for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) + for (fd = 0; fd <= max_desc; ++fd) { if (fd_callback_info[fd].thread != NULL && fd_callback_info[fd].thread != current_thread) @@ -556,7 +562,7 @@ compute_non_process_wait_mask (SELECT_TYPE *mask) int fd; FD_ZERO (mask); - for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) + for (fd = 0; fd <= max_desc; ++fd) { if (fd_callback_info[fd].thread != NULL && fd_callback_info[fd].thread != current_thread) @@ -579,7 +585,7 @@ compute_non_keyboard_wait_mask (SELECT_TYPE *mask) int fd; FD_ZERO (mask); - for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) + for (fd = 0; fd <= max_desc; ++fd) { if (fd_callback_info[fd].thread != NULL && fd_callback_info[fd].thread != current_thread) @@ -602,7 +608,7 @@ compute_write_mask (SELECT_TYPE *mask) int fd; FD_ZERO (mask); - for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) + for (fd = 0; fd <= max_desc; ++fd) { if (fd_callback_info[fd].thread != NULL && fd_callback_info[fd].thread != current_thread) @@ -623,7 +629,7 @@ clear_waiting_thread_info (void) { int fd; - for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) + for (fd = 0; fd <= max_desc; ++fd) { if (fd_callback_info[fd].waiting_thread == current_thread) fd_callback_info[fd].waiting_thread = NULL; @@ -1853,7 +1859,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) XPROCESS (process)->pty_flag = pty_flag; pset_status (XPROCESS (process), Qrun); - add_non_keyboard_read_fd (inchannel); + add_process_read_fd (inchannel); /* This may signal an error. */ setup_process_coding_systems (process); @@ -2107,7 +2113,7 @@ create_pty (Lisp_Object process) pset_status (XPROCESS (process), Qrun); setup_process_coding_systems (process); - add_non_keyboard_read_fd (inchannel); + add_process_read_fd (inchannel); XPROCESS (process)->pid = -2; #ifdef HAVE_PTYS @@ -2729,8 +2735,8 @@ usage: (make-serial-process &rest ARGS) */) fd = serial_open (SSDATA (port)); p->infd = fd; p->outfd = fd; - if (fd > max_process_desc) - max_process_desc = fd; + if (fd > max_desc) + max_desc = fd; chan_process[fd] = proc; buffer = Fplist_get (contact, QCbuffer); @@ -3562,8 +3568,8 @@ usage: (make-network-process &rest ARGS) */) || (EQ (p->status, Qlisten) && NILP (p->command))) add_non_keyboard_read_fd (inch); - if (inch > max_process_desc) - max_process_desc = inch; + if (inch > max_desc) + max_desc = inch; tem = Fplist_member (contact, QCcoding); if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) @@ -4009,16 +4015,8 @@ deactivate_process (Lisp_Object proc) if ((fd_callback_info[inchannel].flags & NON_BLOCKING_CONNECT_FD) != 0) delete_write_fd (inchannel); #endif - if (inchannel == max_process_desc) - { - int i; - /* We just closed the highest-numbered process input descriptor, - so recompute the highest-numbered one now. */ - max_process_desc = 0; - for (i = 0; i < MAXDESC; i++) - if (!NILP (chan_process[i])) - max_process_desc = i; - } + if (inchannel == max_desc) + recompute_max_desc (); } } @@ -4534,8 +4532,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, compute_write_mask (&Ctemp); timeout = make_emacs_time (0, 0); - if ((thread_select (pselect, - max (max_process_desc, max_input_desc) + 1, + if ((thread_select (pselect, max_desc + 1, &Atemp, #ifdef NON_BLOCKING_CONNECT (num_pending_connects > 0 ? &Ctemp : NULL), @@ -4662,7 +4659,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, int nsecs = EMACS_NSECS (timeout); if (EMACS_SECS (timeout) > 0 || nsecs > READ_OUTPUT_DELAY_MAX) nsecs = READ_OUTPUT_DELAY_MAX; - for (channel = 0; check_delay > 0 && channel <= max_process_desc; channel++) + for (channel = 0; check_delay > 0 && channel <= max_desc; channel++) { proc = chan_process[channel]; if (NILP (proc)) @@ -4692,7 +4689,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, #else pselect #endif - , max (max_process_desc, max_input_desc) + 1, + , max_desc + 1, &Available, (check_write ? &Writeok : (SELECT_TYPE *)0), NULL, &timeout, NULL); @@ -4863,7 +4860,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (no_avail || nfds == 0) continue; - for (channel = 0; channel <= max_input_desc; ++channel) + for (channel = 0; channel <= max_desc; ++channel) { struct fd_callback_data *d = &fd_callback_info[channel]; if (d->func @@ -4874,7 +4871,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, d->func (channel, d->data); } - for (channel = 0; channel <= max_process_desc; channel++) + for (channel = 0; channel <= max_desc; channel++) { if (FD_ISSET (channel, &Available) && ((fd_callback_info[channel].flags & (KEYBOARD_FD | PROCESS_FD)) @@ -6669,7 +6666,7 @@ keyboard_bit_set (fd_set *mask) { int fd; - for (fd = 0; fd <= max_input_desc; fd++) + for (fd = 0; fd <= max_desc; fd++) if (FD_ISSET (fd, mask) && ((fd_callback_info[fd].flags & KEYBOARD_FD) != 0)) return 1; @@ -6918,8 +6915,8 @@ add_keyboard_wait_descriptor (int desc) #ifdef subprocesses /* actually means "not MSDOS" */ eassert (desc >= 0 && desc < MAXDESC); fd_callback_info[desc].flags |= FOR_READ | KEYBOARD_FD; - if (desc > max_input_desc) - max_input_desc = desc; + if (desc > max_desc) + max_desc = desc; #endif } @@ -6930,21 +6927,15 @@ delete_keyboard_wait_descriptor (int desc) { #ifdef subprocesses int fd; - int lim = max_input_desc; + int lim = max_desc; + + eassert (desc >= 0 && desc < MAXDESC); + eassert (desc <= max_desc); fd_callback_info[desc].flags &= ~(FOR_READ | KEYBOARD_FD | PROCESS_FD); - if (desc == max_input_desc) - { - for (fd = max_input_desc; fd >= 0; --fd) - { - if (fd_callback_info[desc].flags != 0) - { - max_input_desc = fd; - break; - } - } - } + if (desc == max_desc) + recompute_max_desc (); #endif } @@ -7202,7 +7193,7 @@ init_process_emacs (void) sigaction (SIGCHLD, &action, 0); } - max_process_desc = 0; + max_desc = 0; memset (fd_callback_info, 0, sizeof (fd_callback_info)); #ifdef NON_BLOCKING_CONNECT commit 6bd488cd8d05aa3983ca55f70ee384732d8c0085 Merge: 71f9179 9c44569 Author: Tom Tromey Date: Sun Mar 17 05:17:24 2013 -0600 merge from trunk commit 71f91792e3013b397996905224f387da5cc539a9 Merge: 6f4de08 b542656 Author: Tom Tromey Date: Fri Mar 8 11:57:29 2013 -0700 merge from trunk commit 6f4de085f065e11f4df3195d47479f28f5ef08ba Merge: e078a23 ffe04ad Author: Tom Tromey Date: Wed Jan 16 11:48:32 2013 -0700 merge from trunk commit e078a23febca14bc919c5806670479c395e3253e Merge: 63d535c 7a2657f Author: Tom Tromey Date: Sat Jan 5 19:36:45 2013 -0700 merge from trunk commit 63d535c829a930207b64fe733228f15a554644b1 Author: Tom Tromey Date: Sun Dec 23 15:14:19 2012 -0700 mention let bindings and lack of other ways to rewind diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi index d7e4b0a..9c33354 100644 --- a/doc/lispref/threads.texi +++ b/doc/lispref/threads.texi @@ -31,6 +31,13 @@ local variables are not---a dynamic @code{let} binding is local. Each thread also has its own current buffer (@pxref{Current Buffer}) and its own match data (@pxref{Match Data}). + Note that @code{let} bindings are treated specially by the Emacs +Lisp implementation. There is no way to duplicate this unwinding and +rewinding behavior other than by using @code{let}. For example, a +manual implementation of @code{let} written using +@code{unwind-protect} cannot arrange for variable values to be +thread-specific. + In the case of lexical bindings (@pxref{Variable Scoping}), a closure is an object like any other in Emacs Lisp, and bindings in a closure are shared by any threads invoking the closure. commit 0e10ed2c37cffbad60f61ee7fafde07ad05016f6 Author: Tom Tromey Date: Mon Dec 17 08:48:33 2012 -0700 Remove bit accidentally left over from the merge diff --git a/src/process.c b/src/process.c index 7f647d4..788c917 100644 --- a/src/process.c +++ b/src/process.c @@ -6337,10 +6337,6 @@ handle_child_signal (int sig) /* clear_desc_flag avoids a compiler bug in Microsoft C. */ if (clear_desc_flag) delete_read_fd (p->infd); - { - FD_CLR (p->infd, &input_wait_mask); - FD_CLR (p->infd, &non_keyboard_wait_mask); - } } } } commit 3d6eced1ae51ffd0a782130e7c334052277e2724 Merge: bf69f52 7c3d167 Author: Tom Tromey Date: Mon Dec 17 07:56:22 2012 -0700 merge from trunk commit bf69f522a9e135f9aa483cedd53e71e915f2bf75 Merge: 303324a 6ec9a5a Author: Tom Tromey Date: Tue Sep 4 10:10:06 2012 -0600 merge from trunk commit 303324a9232dbc89369faceb6b3530740d0fc1bd Author: Tom Tromey Date: Tue Sep 4 09:37:58 2012 -0600 link from thread docs to match data diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi index 5c4c62f..d7e4b0a 100644 --- a/doc/lispref/threads.texi +++ b/doc/lispref/threads.texi @@ -28,7 +28,8 @@ thread synchronization. While global variables are shared among all Emacs Lisp threads, local variables are not---a dynamic @code{let} binding is local. Each -thread also has its own current buffer (@pxref{Current Buffer}). +thread also has its own current buffer (@pxref{Current Buffer}) and +its own match data (@pxref{Match Data}). In the case of lexical bindings (@pxref{Variable Scoping}), a closure is an object like any other in Emacs Lisp, and bindings in a commit 587dd92ea0814eafe4064be69d6d9e0fa8dbac1b Author: Tom Tromey Date: Mon Aug 27 10:12:29 2012 -0600 cannot thread-join the current thread diff --git a/src/thread.c b/src/thread.c index 01d2fd0..551f3de 100644 --- a/src/thread.c +++ b/src/thread.c @@ -852,6 +852,9 @@ It is an error for a thread to try to join itself. */) CHECK_THREAD (thread); tstate = XTHREAD (thread); + if (tstate == current_thread) + error ("cannot join current thread"); + if (tstate->m_specpdl != NULL) flush_stack_call_func (thread_join_callback, tstate); diff --git a/test/automated/threads.el b/test/automated/threads.el index b1c2af5..db6aa41 100644 --- a/test/automated/threads.el +++ b/test/automated/threads.el @@ -70,6 +70,10 @@ (and threads-test-global (not (thread-alive-p thread))))))) +(ert-deftest threads-join-self () + "cannot thread-join the current thread" + (should-error (thread-join (current-thread)))) + (defvar threads-test-binding nil) (defun threads-test-thread2 () commit 599d4a99403a8ea40144ca94dbf9f99fb1a038ee Author: Tom Tromey Date: Mon Aug 27 09:27:48 2012 -0600 fix test suite for condition-variable-p name change diff --git a/test/automated/threads.el b/test/automated/threads.el index 87e5eec..b1c2af5 100644 --- a/test/automated/threads.el +++ b/test/automated/threads.el @@ -176,12 +176,12 @@ threads-test-global))) (ert-deftest threads-condvarp () - "simple test of condition-variablep" - (should-not (condition-variablep 'hi))) + "simple test of condition-variable-p" + (should-not (condition-variable-p 'hi))) (ert-deftest threads-condvarp-2 () - "another simple test of condition-variablep" - (should (condition-variablep (make-condition-variable (make-mutex))))) + "another simple test of condition-variable-p" + (should (condition-variable-p (make-condition-variable (make-mutex))))) (ert-deftest threads-condvar-type () "type-of condvar" commit e7c4e870bb26dfc9d2de7b337609a793b35de3e2 Author: Tom Tromey Date: Mon Aug 27 09:26:16 2012 -0600 add tests for variable bindings diff --git a/test/automated/bindings.el b/test/automated/bindings.el new file mode 100644 index 0000000..4b88bae --- /dev/null +++ b/test/automated/bindings.el @@ -0,0 +1,99 @@ +;;; bindings.el --- tests for variable bindings + +;; Copyright (C) 2012 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 . + +;;; Code: + +(defvar binding-test-buffer-A (get-buffer-create "A")) +(defvar binding-test-buffer-B (get-buffer-create "B")) + +(defvar binding-test-always-local 'always) +(make-variable-buffer-local 'binding-test-always-local) + +(defvar binding-test-some-local 'some) +(with-current-buffer binding-test-buffer-A + (set (make-local-variable 'binding-test-some-local) 'local)) + +(ert-deftest binding-test-manual () + "A test case from the elisp manual." + (save-excursion + (set-buffer binding-test-buffer-A) + (let ((binding-test-some-local 'something-else)) + (should (eq binding-test-some-local 'something-else)) + (set-buffer binding-test-buffer-B) + (should (eq binding-test-some-local 'some))) + (should (eq binding-test-some-local 'some)) + (set-buffer binding-test-buffer-A) + (should (eq binding-test-some-local 'local)))) + +(ert-deftest binding-test-setq-default () + "Test that a setq-default has no effect when there is a local binding." + (save-excursion + (set-buffer binding-test-buffer-B) + ;; This variable is not local in this buffer. + (let ((binding-test-some-local 'something-else)) + (setq-default binding-test-some-local 'new-default)) + (should (eq binding-test-some-local 'some)))) + +(ert-deftest binding-test-makunbound () + "Tests of makunbound, from the manual." + (save-excursion + (set-buffer binding-test-buffer-B) + (should (boundp 'binding-test-some-local)) + (let ((binding-test-some-local 'outer)) + (let ((binding-test-some-local 'inner)) + (makunbound 'binding-test-some-local) + (should (not (boundp 'binding-test-some-local)))) + (should (and (boundp 'binding-test-some-local) + (eq binding-test-some-local 'outer)))))) + +(ert-deftest binding-test-defvar-bool () + "Test DEFVAR_BOOL" + (let ((display-hourglass 5)) + (should (eq display-hourglass t)))) + +(ert-deftest binding-test-defvar-int () + "Test DEFVAR_INT" + (should-error (setq gc-cons-threshold 5.0) :type 'wrong-type-argument)) + +(ert-deftest binding-test-set-constant-t () + "Test setting the constant t" + (should-error (setq t 'bob) :type 'setting-constant)) + +(ert-deftest binding-test-set-constant-nil () + "Test setting the constant nil" + (should-error (setq nil 'bob) :type 'setting-constant)) + +(ert-deftest binding-test-set-constant-keyword () + "Test setting a keyword constant" + (should-error (setq :keyword 'bob) :type 'setting-constant)) + +(ert-deftest binding-test-set-constant-nil () + "Test setting a keyword to itself" + (should (setq :keyword :keyword))) + +;; More tests to write - +;; kill-local-variable +;; defconst; can modify +;; defvar and defconst modify the local binding [ doesn't matter for us ] +;; various kinds of special internal forwarding objects +;; a couple examples in manual, not enough +;; frame-local vars +;; variable aliases + +;;; bindings.el ends here commit 09d7066e2291651805b7bfd5edbf45562766e122 Author: Tom Tromey Date: Sat Aug 25 14:09:04 2012 -0600 minor update to thread-join docs diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi index 434915c..5c4c62f 100644 --- a/doc/lispref/threads.texi +++ b/doc/lispref/threads.texi @@ -67,7 +67,9 @@ thread, @code{nil} otherwise. @end defun @defun thread-join thread -Block until @var{thread} exits, or until the current thread is signaled. +Block until @var{thread} exits, or until the current thread is +signaled. If @var{thread} has already exited, this returns +immediately. @end defun @defun thread-signal thread error-symbol data commit 58c8e9a4debc3ef2c672a34d58720d5bf0530d12 Author: Tom Tromey Date: Fri Aug 24 09:28:02 2012 -0600 minor documentation updates diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi index 8094a68..434915c 100644 --- a/doc/lispref/threads.texi +++ b/doc/lispref/threads.texi @@ -27,7 +27,8 @@ also to create and control mutexes and condition variables, useful for thread synchronization. While global variables are shared among all Emacs Lisp threads, -local variables are not---a dynamic @code{let} binding is local. +local variables are not---a dynamic @code{let} binding is local. Each +thread also has its own current buffer (@pxref{Current Buffer}). In the case of lexical bindings (@pxref{Variable Scoping}), a closure is an object like any other in Emacs Lisp, and bindings in a @@ -50,6 +51,9 @@ threads can be signaled. Create a new thread of execution which invokes @var{function}. When @var{function} returns, the thread exits. +The new thread is created with no local variable bindings in effect. +The new thread's current buffer is inherited from the current thread. + @var{name} can be supplied to give a name to the thread. The name is used for debugging and informational purposes only; it has no meaning to Emacs. If @var{name} is provided, it must be a string. commit c2283a75564d7794fb5f604eafc6b65f71146e7f Author: Tom Tromey Date: Thu Aug 23 14:00:38 2012 -0600 document until-condition diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi index 7604528..8094a68 100644 --- a/doc/lispref/threads.texi +++ b/doc/lispref/threads.texi @@ -236,3 +236,9 @@ Return the name of @var{cond}, as passed to Return the mutex associated with @var{cond}. Note that the associated mutex cannot be changed. @end defun + +@defmac until-condition test cond +Acquire the mutex associated with @var{cond}, and then loop, invoking +the form @var{test}. If @var{test} evaluates to @code{nil}, invoke +@code{condition-wait} on @var{cond}. +@end defmac commit 0ec3764d398add8c038b317201d139aaef4a594e Author: Tom Tromey Date: Thu Aug 23 13:58:38 2012 -0600 first draft of threads documentation diff --git a/doc/lispref/Makefile.in b/doc/lispref/Makefile.in index 32a241e..626efc5 100644 --- a/doc/lispref/Makefile.in +++ b/doc/lispref/Makefile.in @@ -94,6 +94,7 @@ srcs = \ $(srcdir)/symbols.texi \ $(srcdir)/syntax.texi \ $(srcdir)/text.texi \ + $(srcdir)/threads.texi \ $(srcdir)/tips.texi \ $(srcdir)/variables.texi \ $(srcdir)/windows.texi \ diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index caa5185..61828ef 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -210,6 +210,7 @@ Cover art by Etienne Suvasa. * Syntax Tables:: The syntax table controls word and list parsing. * Abbrevs:: How Abbrev mode works, and its data structures. +* Threads:: Concurrency in Emacs Lisp. * Processes:: Running and communicating with subprocesses. * Display:: Features for controlling the screen display. * System Interface:: Getting the user id, system type, environment @@ -1269,6 +1270,12 @@ Abbrevs and Abbrev Expansion * Abbrev Table Properties:: How to read and set abbrev table properties. Which properties have which effect. +Threads + +* Basic Thread Functions:: Basic thread functions. +* Mutexes:: Mutexes allow exclusive access to data. +* Condition Variables:: Inter-thread events. + Processes * Subprocess Creation:: Functions that start subprocesses. @@ -1571,6 +1578,7 @@ Object Internals @include searching.texi @include syntax.texi @include abbrevs.texi +@include threads.texi @include processes.texi @include display.texi diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index 7d40f0f..9033681 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -1885,6 +1885,15 @@ with references to further information. @item string-or-null-p @xref{Predicates for Strings, string-or-null-p}. + +@item threadp +@xref{Basic Thread Functions, threadp}. + +@item mutexp +@xref{Mutexes, mutexp}. + +@item condition-variable-p +@xref{Condition Variables, condition-variable-p}. @end table The most general way to check the type of an object is to call the @@ -1898,11 +1907,12 @@ types. In most cases, it is more convenient to use type predicates than This function returns a symbol naming the primitive type of @var{object}. The value is one of the symbols @code{bool-vector}, @code{buffer}, @code{char-table}, @code{compiled-function}, -@code{cons}, @code{float}, @code{font-entity}, @code{font-object}, -@code{font-spec}, @code{frame}, @code{hash-table}, @code{integer}, -@code{marker}, @code{overlay}, @code{process}, @code{string}, -@code{subr}, @code{symbol}, @code{vector}, @code{window}, or -@code{window-configuration}. +@code{condition-variable}, @code{cons}, @code{float}, +@code{font-entity}, @code{font-object}, @code{font-spec}, +@code{frame}, @code{hash-table}, @code{integer}, @code{marker}, +@code{mutex}, @code{overlay}, @code{process}, @code{string}, +@code{subr}, @code{symbol}, @code{thread}, @code{vector}, +@code{window}, or @code{window-configuration}. @example (type-of 1) diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi new file mode 100644 index 0000000..7604528 --- /dev/null +++ b/doc/lispref/threads.texi @@ -0,0 +1,238 @@ +@c -*-texinfo-*- +@c This is part of the GNU Emacs Lisp Reference Manual. +@c Copyright (C) 2012 +@c Free Software Foundation, Inc. +@c See the file elisp.texi for copying conditions. +@node Threads +@chapter Threads +@cindex threads +@cindex concurrency + + Emacs Lisp provides a limited form of concurrency, called +@dfn{threads}. All the threads in a given instance of Emacs share the +same memory. Concurrency in Emacs Lisp is ``mostly cooperative'', +meaning that Emacs will only switch execution between threads at +well-defined times. However, the Emacs thread support has been +designed in a way to later allow more fine-grained concurrency, and +correct programs should not rely on cooperative threading. + + Currently, thread switching will occur upon explicit request via +@code{thread-yield}, when waiting for keyboard input or for process +output (e.g., during @code{accept-process-output}), or during blocking +operations relating to threads, such as mutex locking or +@code{thread-join}. + + Emacs Lisp provides primitives to create and control threads, and +also to create and control mutexes and condition variables, useful for +thread synchronization. + + While global variables are shared among all Emacs Lisp threads, +local variables are not---a dynamic @code{let} binding is local. + + In the case of lexical bindings (@pxref{Variable Scoping}), a +closure is an object like any other in Emacs Lisp, and bindings in a +closure are shared by any threads invoking the closure. + +@menu +* Basic Thread Functions:: Basic thread functions. +* Mutexes:: Mutexes allow exclusive access to data. +* Condition Variables:: Inter-thread events. +@end menu + +@node Basic Thread Functions +@section Basic Thread Functions + + Threads can be created and waited for. A thread cannot be exited +directly, but the current thread can be exited implicitly, and other +threads can be signaled. + +@defun make-thread function &optional name +Create a new thread of execution which invokes @var{function}. When +@var{function} returns, the thread exits. + +@var{name} can be supplied to give a name to the thread. The name is +used for debugging and informational purposes only; it has no meaning +to Emacs. If @var{name} is provided, it must be a string. + +This function returns the new thread. +@end defun + +@defun threadp object +This function returns @code{t} if @var{object} represents an Emacs +thread, @code{nil} otherwise. +@end defun + +@defun thread-join thread +Block until @var{thread} exits, or until the current thread is signaled. +@end defun + +@defun thread-signal thread error-symbol data +Like @code{signal} (@pxref{Signaling Errors}), but the signal is +delivered in the thread @var{thread}. If @var{thread} is the current +thread, then this just calls @code{signal} immediately. +@code{thread-signal} will cause a thread to exit a call to +@code{mutex-lock}, @code{condition-wait}, or @code{thread-join}. +@end defun + +@defun thread-yield +Yield execution to the next runnable thread. +@end defun + +@defun thread-name thread +Return the name of @var{thread}, as specified to @code{make-thread}. +@end defun + +@defun thread-alive-p thread +Return @code{t} if @var{thread} is alive, or @code{nil} if it is not. +A thread is alive as long as its function is still executing. +@end defun + +@defun thread-blocker thread +Return the object that @var{thread} is waiting on. This function is +primarily intended for debugging. + +If @var{thread} is blocked in @code{thread-join}, this returns the +thread for which it is waiting. + +If @var{thread} is blocked in @code{mutex-lock}, this returns the mutex. + +If @var{thread} is blocked in @code{condition-wait}, this returns the +condition variable. + +Otherwise, this returns @code{nil}. +@end defun + +@defun current-thread +Return the current thread. +@end defun + +@defun all-threads +Return a list of all the live thread objects. A new list is returned +by each invocation. +@end defun + +@node Mutexes +@section Mutexes + + A @dfn{mutex} is an exclusive lock. At any moment, zero or one +threads may own a mutex. If a thread attempts to acquire a mutex, and +the mutex is already owned by some other thread, then the acquiring +thread will block until the mutex becomes available. + + Emacs Lisp mutexes are of a type called @dfn{recursive}, which means +that a thread can re-acquire a mutex it owns any number of times. A +mutex keeps a count of how many times it has been acquired, and each +acquisition of a mutex must be paired with a release. The last +release by a thread of a mutex reverts it to the unowned state, +potentially allowing another thread to acquire the mutex. + +@defun mutexp object +This function returns @code{t} if @var{object} represents an Emacs +mutex, @code{nil} otherwise. +@end defun + +@defun make-mutex &optional name +Create a new mutex and return it. If @var{name} is specified, it is a +name given to the mutex. It must be a string. The name is for +debugging purposes only; it has no meaning to Emacs. +@end defun + +@defun mutex-name mutex +Return the name of @var{mutex}, as specified to @code{make-mutex}. +@end defun + +@defun mutex-lock mutex +This will block until this thread acquires @var{mutex}, or until this +thread is signaled using @code{thread-signal}. If @var{mutex} is +already owned by this thread, this simply returns. +@end defun + +@defun mutex-unlock mutex +Release @var{mutex}. If @var{mutex} is not owned by this thread, this +will signal an error. +@end defun + +@defmac with-mutex mutex body@dots{} +This macro is the simplest and safest way to evaluate forms while +holding a mutex. It acquires @var{mutex}, invokes @var{body}, and +then releases @var{mutex}. It returns the result of @var{body}. +@end defmac + +@node Condition Variables +@section Condition Variables + + A @dfn{condition variable} is a way for a thread to block until some +event occurs. A thread can wait on a condition variable, to be woken +up when some other thread notifies the condition. + + A condition variable is associated with a mutex and, conceptually, +with some condition. For proper operation, the mutex must be +acquired, and then a waiting thread must loop, testing the condition +and waiting on the condition variable. For example: + +@example +(with-mutex mutex + (while (not global-variable) + (condition-wait cond-var))) +@end example + + The mutex ensures atomicity, and the loop is for robustness---there +may be spurious notifications. Emacs Lisp provides a macro, +@code{until-condition}, to do this automatically. + + Similarly, the mutex must be held before notifying the condition. +The typical, and best, approach is to acquire the mutex, make the +changes associated with this condition, and then signal it: + +@example +(with-mutex mutex + (setq global-variable (some-computation)) + (condition-signal cond-var)) +@end example + +@defun make-condition-variable mutex &optional name +Make a new condition variable associated with @var{mutex}. If +@var{name} is specified, it is a name given to the condition variable. +It must be a string. The name is for debugging purposes only; it has +no meaning to Emacs. +@end defun + +@defun condition-variable-p object +This function returns @code{t} if @var{object} represents a condition +variable, @code{nil} otherwise. +@end defun + +@defun condition-wait cond +Wait for another thread to notify @var{cond}, a condition variable. +This function will block until the condition is notified, or until a +signal is delivered to this thread using @code{thread-signal}. + +It is an error to call @code{condition-wait} without holding the +condition's associated mutex. + +@code{condition-wait} releases the associated mutex while waiting. +This allows other threads to acquire the mutex in order to notify the +condition. +@end defun + +@defun condition-notify cond &optional all +Notify @var{cond}. The mutex with @var{cond} must be held before +calling this. Ordinarily a single waiting thread is woken by +@code{condition-notify}; but if @var{all} is not @code{nil}, then all +threads waiting on @var{cond} are notified. + +@code{condition-notify} releases the associated mutex while waiting. +This allows other threads to acquire the mutex in order to wait on the +condition. +@c why bother? +@end defun + +@defun condition-name cond +Return the name of @var{cond}, as passed to +@code{make-condition-variable}. +@end defun + +@defun condition-mutex cond +Return the mutex associated with @var{cond}. Note that the associated +mutex cannot be changed. +@end defun commit c6bb874290bb0d56d2caa106fc3989cf34a72c3e Author: Tom Tromey Date: Thu Aug 23 01:11:22 2012 -0600 rename condition-variablep to condition-variable-p diff --git a/src/data.c b/src/data.c index fa40f14..ac6c7af 100644 --- a/src/data.c +++ b/src/data.c @@ -485,7 +485,7 @@ DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0, return Qnil; } -DEFUN ("condition-variablep", Fcondition_variablep, Scondition_variablep, +DEFUN ("condition-variable-p", Fcondition_variable_p, Scondition_variable_p, 1, 1, 0, doc: /* Return t if OBJECT is a condition variable. */) (Lisp_Object object) @@ -3174,7 +3174,7 @@ syms_of_data (void) defsubr (&Schar_or_string_p); defsubr (&Sthreadp); defsubr (&Smutexp); - defsubr (&Scondition_variablep); + defsubr (&Scondition_variable_p); defsubr (&Scar); defsubr (&Scdr); defsubr (&Scar_safe); commit 66ddd174be5aaf2c70666adc4046615cf3413d5b Author: Tom Tromey Date: Thu Aug 23 01:06:11 2012 -0600 document process-thread and set-process-thread diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 217f9f9..80a3d0f 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -1174,6 +1174,7 @@ shell command. * Filter Functions:: Filter functions accept output from the process. * Decoding Output:: Filters can get unibyte or multibyte strings. * Accepting Output:: How to wait until process output arrives. +* Processes and Threads:: How processes and threads interact. @end menu @node Process Buffers @@ -1504,6 +1505,35 @@ did get some output, or @code{nil} if the timeout expired before output arrived. @end defun +@node Processes and Threads +@subsection Processes and Threads +@cindex processes, threads + + Because threads were a relatively late addition to Emacs Lisp, and +due to the way dynamic binding was sometimes used in conjunction with +@code{accept-process-output}, by default a process is locked to the +thread that created it. When a process is locked to a thread, output +from the process can only be accepted by that thread. + + A Lisp program can specify to which thread a process is to be +locked, or instruct Emacs to unlock a process, in which case its +output can be processed by any thread. Only a single thread will wait +for output from a given process at one time---once one thread begins +waiting for output, the process is temporarily locked until +@code{accept-process-output} or @code{sit-for} returns. + + If the thread exits, all the processes locked to it are unlocked. + +@defun process-thread process +Return the thread to which @var{process} is locked. If @var{process} +is unlocked, return @code{nil}. +@end defun + +@defun set-process-thread process thread +Set the locking thread of @var{process} to @var{thread}. @var{thread} +may be @code{nil}, in which case the process is unlocked. +@end defun + @node Sentinels @section Sentinels: Detecting Process Status Changes @cindex process sentinel commit 68608de20310c42c5719fe99e556847fac9dd1f2 Author: Tom Tromey Date: Mon Aug 20 12:17:36 2012 -0600 pass the thread name to the OS if possible use prctl to pass the thread name to the OS, if possible diff --git a/configure.ac b/configure.ac index 2394790..90c0ef0 100644 --- a/configure.ac +++ b/configure.ac @@ -1230,7 +1230,7 @@ AC_CHECK_HEADERS_ONCE( linux/version.h sys/systeminfo.h stdio_ext.h fcntl.h coff.h pty.h sys/vlimit.h sys/resource.h - sys/utsname.h pwd.h utmp.h dirent.h util.h) + sys/utsname.h pwd.h utmp.h dirent.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)]])], @@ -2731,7 +2731,7 @@ gai_strerror mkstemp getline getdelim fsync sync \ difftime posix_memalign \ getpwent endpwent getgrent endgrent \ touchlock \ -cfmakeraw cfsetspeed copysign __executable_start) +cfmakeraw cfsetspeed copysign __executable_start prctl) dnl getwd appears to be buggy on SVR4.2, so we don't use it. if test $opsys = unixware; then diff --git a/src/systhread.c b/src/systhread.c index 666641c..ab64752 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -24,6 +24,10 @@ along with GNU Emacs. If not, see . */ #include +#ifdef HAVE_SYS_PRCTL_H +#include +#endif + void sys_mutex_init (sys_mutex_t *mutex) { @@ -91,8 +95,8 @@ sys_thread_equal (sys_thread_t one, sys_thread_t two) } int -sys_thread_create (sys_thread_t *thread_ptr, thread_creation_function *func, - void *arg) +sys_thread_create (sys_thread_t *thread_ptr, const char *name, + thread_creation_function *func, void *arg) { pthread_attr_t attr; int result = 0; @@ -101,7 +105,13 @@ sys_thread_create (sys_thread_t *thread_ptr, thread_creation_function *func, return 0; if (!pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED)) - result = pthread_create (thread_ptr, &attr, func, arg) == 0; + { + result = pthread_create (thread_ptr, &attr, func, arg) == 0; +#if defined (HAVE_SYS_PRCTL_H) && defined (HAVE_PRCTL) && defined (PR_SET_NAME) + if (result && name != NULL) + prctl (PR_SET_NAME, name); +#endif + } pthread_attr_destroy (&attr); diff --git a/src/systhread.h b/src/systhread.h index 790b385..bbd242a 100644 --- a/src/systhread.h +++ b/src/systhread.h @@ -54,7 +54,8 @@ extern void sys_cond_destroy (sys_cond_t *); extern sys_thread_t sys_thread_self (void); extern int sys_thread_equal (sys_thread_t, sys_thread_t); -extern int sys_thread_create (sys_thread_t *, thread_creation_function *, +extern int sys_thread_create (sys_thread_t *, const char *, + thread_creation_function *, void *); extern void sys_thread_yield (void); diff --git a/src/thread.c b/src/thread.c index dba84fd..01d2fd0 100644 --- a/src/thread.c +++ b/src/thread.c @@ -23,6 +23,7 @@ along with GNU Emacs. If not, see . */ #include "character.h" #include "buffer.h" #include "process.h" +#include "coding.h" static struct thread_state primary_thread; @@ -682,6 +683,7 @@ If NAME is given, it names the new thread. */) sys_thread_t thr; struct thread_state *new_thread; Lisp_Object result; + const char *c_name = NULL; /* Can't start a thread in temacs. */ if (!initialized) @@ -716,7 +718,10 @@ If NAME is given, it names the new thread. */) new_thread->next_thread = all_threads; all_threads = new_thread; - if (! sys_thread_create (&thr, run_thread, 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; commit fb77afbe75308507885113a56017f095da8ba1cc Author: Tom Tromey Date: Mon Aug 20 07:56:02 2012 -0600 add convenience macros with-mutex and until-condition with-mutex is a safe way to run some code with a mutex held. until-condition is a safe way to wait on a condition variable. diff --git a/lisp/subr.el b/lisp/subr.el index 74afd59..9578320 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4304,6 +4304,34 @@ as alpha versions." (version-list-= (version-to-list v1) (version-to-list v2))) +;;; 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))))) + +(defmacro until-condition (test condition) + "Wait for the condition variable CONDITION, checking TEST. +Acquire CONDITION's mutex, then check TEST. +If TEST evaluates to nil, repeatedly invoke `condition-wait' on CONDITION. +When CONDITION is signalled, check TEST again. + +This is the simplest safe way to invoke `condition-wait'." + (let ((cond-sym (make-symbol "condition"))) + `(let ((,cond-sym ,condition)) + (with-mutex (condition-mutex ,cond-sym) + (while (not ,test) + (condition-wait ,cond-sym)))))) + + + ;;; Misc. (defconst menu-bar-separator '("--") "Separator for menus.") commit 49bc1a9dfc6e81a370bf12157c3c573743ee200a Merge: b94de89 a05731a Author: Tom Tromey Date: Mon Aug 20 07:34:41 2012 -0600 Merge from trunk commit b94de893429bbfbb27572c8c3118fcc876957adb Author: Tom Tromey Date: Sun Aug 19 03:38:30 2012 -0600 another docstring fixlet diff --git a/src/thread.c b/src/thread.c index 608c3b8..dba84fd 100644 --- a/src/thread.c +++ b/src/thread.c @@ -348,7 +348,8 @@ 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. When +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) commit 266c1c2fd96e4b25d755838dcf68c0c992a8a263 Author: Tom Tromey Date: Sun Aug 19 03:36:50 2012 -0600 minor docstring fixup diff --git a/src/thread.c b/src/thread.c index 4c21418..608c3b8 100644 --- a/src/thread.c +++ b/src/thread.c @@ -348,9 +348,9 @@ 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 atomically releases the mutex and waits for CONDITION to be -notified. When `condition-wait' returns, the mutex will again be -locked by this thread. */) +This releases the mutex and waits for CONDITION to be notified. When +`condition-wait' returns, the mutex will again be locked by this +thread. */) (Lisp_Object condition) { struct Lisp_CondVar *cvar; @@ -402,7 +402,7 @@ 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 atomically releases the mutex when notifying CONDITION. When +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) commit 1fb339bccd65db50adc2ad7f7290099808fc439d Author: Tom Tromey Date: Sun Aug 19 03:31:57 2012 -0600 add condition-mutex and condition-name diff --git a/src/thread.c b/src/thread.c index b8ffb06..4c21418 100644 --- a/src/thread.c +++ b/src/thread.c @@ -425,6 +425,31 @@ thread. */) 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) { @@ -898,6 +923,8 @@ syms_of_threads (void) defsubr (&Smake_condition_variable); defsubr (&Scondition_wait); defsubr (&Scondition_notify); + defsubr (&Scondition_mutex); + defsubr (&Scondition_name); Qthreadp = intern_c_string ("threadp"); staticpro (&Qthreadp); diff --git a/test/automated/threads.el b/test/automated/threads.el index ce929fc..87e5eec 100644 --- a/test/automated/threads.el +++ b/test/automated/threads.el @@ -188,4 +188,22 @@ (should (eq (type-of (make-condition-variable (make-mutex))) 'condition-variable))) +(ert-deftest threads-condvar-mutex () + "simple test of condition-mutex" + (should + (let ((m (make-mutex))) + (eq m (condition-mutex (make-condition-variable m)))))) + +(ert-deftest threads-condvar-name () + "simple test of condition-name" + (should + (eq nil (condition-name (make-condition-variable (make-mutex)))))) + +(ert-deftest threads-condvar-name-2 () + "another simple test of condition-name" + (should + (string= "hi bob" + (condition-name (make-condition-variable (make-mutex) + "hi bob"))))) + ;;; threads.el ends here commit 9dad5e59e30c1b0d1047838048510f59552be492 Author: Tom Tromey Date: Sun Aug 19 03:26:42 2012 -0600 ensure name of a thread is a string diff --git a/src/thread.c b/src/thread.c index 8fa43dd..b8ffb06 100644 --- a/src/thread.c +++ b/src/thread.c @@ -661,6 +661,9 @@ If NAME is given, it names the new thread. */) if (!initialized) abort (); + if (!NILP (name)) + CHECK_STRING (name); + new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_gcprolist, PVEC_THREAD); memset ((char *) new_thread + offsetof (struct thread_state, m_gcprolist), commit 3cbf5b1d3b7b9a89e1ef6b00a5ab91d58959f9ab Author: Tom Tromey Date: Sun Aug 19 03:26:09 2012 -0600 ensure name of a mutex is a string diff --git a/src/thread.c b/src/thread.c index 83f25e8..8fa43dd 100644 --- a/src/thread.c +++ b/src/thread.c @@ -185,6 +185,9 @@ informational only. */) 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, commit 977c4aa65f42a1cf2c07ea92a6190c18c349b2e7 Author: Tom Tromey Date: Sun Aug 19 03:25:06 2012 -0600 use NILP diff --git a/src/thread.c b/src/thread.c index 4657d6a..83f25e8 100644 --- a/src/thread.c +++ b/src/thread.c @@ -61,7 +61,7 @@ post_acquire_global_lock (struct thread_state *self) self->m_current_buffer = 0; set_buffer_internal (XBUFFER (buffer)); - if (!EQ (current_thread->error_symbol, Qnil)) + if (!NILP (current_thread->error_symbol)) { Lisp_Object sym = current_thread->error_symbol; Lisp_Object data = current_thread->error_data; @@ -110,7 +110,7 @@ lisp_mutex_lock (lisp_mutex_t *mutex, int new_count) self = current_thread; self->wait_condvar = &mutex->condition; while (mutex->owner != NULL && (new_count != 0 - || EQ (self->error_symbol, Qnil))) + || NILP (self->error_symbol))) sys_cond_wait (&mutex->condition, &global_lock); self->wait_condvar = NULL; @@ -796,7 +796,7 @@ thread_join_callback (void *arg) XSETTHREAD (thread, tstate); self->event_object = thread; self->wait_condvar = &tstate->thread_condvar; - while (tstate->m_specpdl != NULL && EQ (self->error_symbol, Qnil)) + while (tstate->m_specpdl != NULL && NILP (self->error_symbol)) sys_cond_wait (self->wait_condvar, &global_lock); self->wait_condvar = NULL; commit 5651640d578fa2efa40be4789d9fa61813ccb1fa Author: Tom Tromey Date: Sun Aug 19 03:23:03 2012 -0600 condition variables This implements condition variables for elisp. This needs more tests. diff --git a/src/alloc.c b/src/alloc.c index 80d22d6..19b77d5 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3106,6 +3106,8 @@ sweep_vectors (void) finalize_one_thread ((struct thread_state *) vector); else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX)) finalize_one_mutex ((struct Lisp_Mutex *) vector); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR)) + finalize_one_condvar ((struct Lisp_CondVar *) vector); next = ADVANCE (vector, nbytes); diff --git a/src/data.c b/src/data.c index b47c2d1..e6342ca 100644 --- a/src/data.c +++ b/src/data.c @@ -94,7 +94,7 @@ static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; static Lisp_Object Qsubrp, Qmany, Qunevalled; Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; static Lisp_Object Qdefun; -Lisp_Object Qthread, Qmutex; +Lisp_Object Qthread, Qmutex, Qcondition_variable; Lisp_Object Qinteractive_form; @@ -216,6 +216,8 @@ for example, (type-of 1) returns `integer'. */) return Qthread; if (MUTEXP (object)) return Qmutex; + if (CONDVARP (object)) + return Qcondition_variable; return Qvector; case Lisp_Float: @@ -482,6 +484,17 @@ DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0, else return Qnil; } + +DEFUN ("condition-variablep", Fcondition_variablep, Scondition_variablep, + 1, 1, 0, + doc: /* Return t if OBJECT is a condition variable. */) + (Lisp_Object object) +{ + if (CONDVARP (object)) + return Qt; + else + return Qnil; +} /* Extract and set components of lists */ @@ -3117,6 +3130,7 @@ syms_of_data (void) DEFSYM (Qhash_table, "hash-table"); DEFSYM (Qthread, "thread"); DEFSYM (Qmutex, "mutex"); + DEFSYM (Qcondition_variable, "condition-variable"); /* Used by Fgarbage_collect. */ DEFSYM (Qinterval, "interval"); DEFSYM (Qmisc, "misc"); @@ -3161,6 +3175,7 @@ syms_of_data (void) defsubr (&Schar_or_string_p); defsubr (&Sthreadp); defsubr (&Smutexp); + defsubr (&Scondition_variablep); defsubr (&Scar); defsubr (&Scdr); defsubr (&Scar_safe); diff --git a/src/lisp.h b/src/lisp.h index 34ecfe6..2a75dfc 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -367,6 +367,7 @@ enum pvec_type PVEC_OTHER, PVEC_THREAD, PVEC_MUTEX, + PVEC_CONDVAR, /* These last 4 are special because we OR them in fns.c:internal_equal, so they have to use a disjoint bit pattern: if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE @@ -557,6 +558,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) XUNTAG (a, Lisp_Vectorlike))) #define XTHREAD(a) (eassert (THREADP (a)), (struct thread_state *) XPNTR(a)) #define XMUTEX(a) (eassert (MUTEXP (a)), (struct Lisp_Mutex *) XPNTR(a)) +#define XCONDVAR(a) (eassert (CONDVARP (a)), (struct Lisp_CondVar *) XPNTR(a)) /* Construct a Lisp_Object from a value or address. */ @@ -609,6 +611,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) #define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE)) #define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD)) #define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX)) +#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR)) /* Convenience macros for dealing with Lisp arrays. */ @@ -1709,6 +1712,7 @@ typedef struct { #define FRAMEP(x) PSEUDOVECTORP (x, PVEC_FRAME) #define THREADP(x) PSEUDOVECTORP (x, PVEC_THREAD) #define MUTEXP(x) PSEUDOVECTORP (x, PVEC_MUTEX) +#define CONDVARP(x) PSEUDOVECTORP (x, PVEC_CONDVAR) /* Test for image (image . spec) */ #define IMAGEP(x) (CONSP (x) && EQ (XCAR (x), Qimage)) @@ -1833,6 +1837,9 @@ typedef struct { #define CHECK_MUTEX(x) \ CHECK_TYPE (MUTEXP (x), Qmutexp, x) +#define CHECK_CONDVAR(x) \ + CHECK_TYPE (CONDVARP (x), Qcondition_variablep, x) + /* Since we can't assign directly to the CAR or CDR fields of a cons cell, use these when checking that those fields contain numbers. */ #define CHECK_NUMBER_CAR(x) \ @@ -2455,7 +2462,7 @@ extern Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp; extern Lisp_Object Qbuffer_or_string_p; extern Lisp_Object Qfboundp; extern Lisp_Object Qchar_table_p, Qvector_or_char_table_p; -extern Lisp_Object Qthreadp, Qmutexp; +extern Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep; extern Lisp_Object Qcdr; diff --git a/src/print.c b/src/print.c index b14a769..78a0707 100644 --- a/src/print.c +++ b/src/print.c @@ -1967,6 +1967,18 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag } PRINTCHAR ('>'); } + else if (CONDVARP (obj)) + { + strout ("#name)) + print_string (XCONDVAR (obj)->name, printcharfun); + else + { + int len = sprintf (buf, "%p", XCONDVAR (obj)); + strout (buf, len, len, printcharfun); + } + PRINTCHAR ('>'); + } else { ptrdiff_t size = ASIZE (obj); diff --git a/src/thread.c b/src/thread.c index 9c39b84..4657d6a 100644 --- a/src/thread.c +++ b/src/thread.c @@ -32,7 +32,7 @@ static struct thread_state *all_threads = &primary_thread; static sys_mutex_t global_lock; -Lisp_Object Qthreadp, Qmutexp; +Lisp_Object Qthreadp, Qmutexp, Qcondition_variablep; @@ -89,36 +89,41 @@ lisp_mutex_init (lisp_mutex_t *mutex) sys_cond_init (&mutex->condition); } -static void -lisp_mutex_lock (lisp_mutex_t *mutex) +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 = 1; - return; + mutex->count = new_count == 0 ? 1 : new_count; + return 0; } if (mutex->owner == current_thread) { + eassert (new_count == 0); ++mutex->count; - return; + return 0; } self = current_thread; self->wait_condvar = &mutex->condition; - while (mutex->owner != NULL && EQ (self->error_symbol, Qnil)) + while (mutex->owner != NULL && (new_count != 0 + || EQ (self->error_symbol, Qnil))) sys_cond_wait (&mutex->condition, &global_lock); self->wait_condvar = NULL; - post_acquire_global_lock (self); + if (new_count == 0 && !NILP (self->error_symbol)) + return 1; mutex->owner = self; - mutex->count = 1; + mutex->count = new_count == 0 ? 1 : new_count; + + return 1; } -static void +static int lisp_mutex_unlock (lisp_mutex_t *mutex) { struct thread_state *self = current_thread; @@ -127,12 +132,28 @@ lisp_mutex_unlock (lisp_mutex_t *mutex) error ("blah"); if (--mutex->count > 0) - return; + return 0; mutex->owner = NULL; sys_cond_broadcast (&mutex->condition); - post_acquire_global_lock (self); + 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 @@ -141,6 +162,12 @@ 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, @@ -173,9 +200,10 @@ static void mutex_lock_callback (void *arg) { struct Lisp_Mutex *mutex = arg; + struct thread_state *self = current_thread; - /* This calls post_acquire_global_lock. */ - lisp_mutex_lock (&mutex->mutex); + if (lisp_mutex_lock (&mutex->mutex, 0)) + post_acquire_global_lock (self); } static Lisp_Object @@ -211,9 +239,10 @@ static void mutex_unlock_callback (void *arg) { struct Lisp_Mutex *mutex = arg; + struct thread_state *self = current_thread; - /* This calls post_acquire_global_lock. */ - lisp_mutex_unlock (&mutex->mutex); + if (lisp_mutex_unlock (&mutex->mutex)) + post_acquire_global_lock (self); } DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0, @@ -253,6 +282,154 @@ finalize_one_mutex (struct Lisp_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); + current_thread->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); + current_thread->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 atomically releases the mutex and waits for CONDITION to be +notified. 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 atomically 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; +} + +void +finalize_one_condvar (struct Lisp_CondVar *condvar) +{ + sys_cond_destroy (&condvar->cond); +} + + + struct select_args { select_func *func; @@ -555,8 +732,8 @@ 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' or`thread-join' in -the target thread. */) +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; @@ -597,6 +774,7 @@ DEFUN ("thread-blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0, 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) { @@ -711,9 +889,14 @@ syms_of_threads (void) defsubr (&Smutex_lock); defsubr (&Smutex_unlock); defsubr (&Smutex_name); + defsubr (&Smake_condition_variable); + defsubr (&Scondition_wait); + defsubr (&Scondition_notify); Qthreadp = intern_c_string ("threadp"); staticpro (&Qthreadp); Qmutexp = intern_c_string ("mutexp"); staticpro (&Qmutexp); + Qcondition_variablep = intern_c_string ("condition-variablep"); + staticpro (&Qcondition_variablep); } diff --git a/src/thread.h b/src/thread.h index 6b66ea4..989acec 100644 --- a/src/thread.h +++ b/src/thread.h @@ -215,11 +215,27 @@ struct Lisp_Mutex 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); diff --git a/test/automated/threads.el b/test/automated/threads.el index 4c1afbd..ce929fc 100644 --- a/test/automated/threads.el +++ b/test/automated/threads.el @@ -175,4 +175,17 @@ (accept-process-output nil 1)) threads-test-global))) +(ert-deftest threads-condvarp () + "simple test of condition-variablep" + (should-not (condition-variablep 'hi))) + +(ert-deftest threads-condvarp-2 () + "another simple test of condition-variablep" + (should (condition-variablep (make-condition-variable (make-mutex))))) + +(ert-deftest threads-condvar-type () + "type-of condvar" + (should (eq (type-of (make-condition-variable (make-mutex))) + 'condition-variable))) + ;;; threads.el ends here commit ee1464eab19311ab7708b135bdb6eb989909e4cc Author: Tom Tromey Date: Sat Aug 18 20:05:13 2012 -0600 comment fixes diff --git a/src/thread.h b/src/thread.h index 32ef48f..6b66ea4 100644 --- a/src/thread.h +++ b/src/thread.h @@ -187,7 +187,7 @@ struct thread_state struct thread_state *next_thread; }; -/* A mutex in lisp is represented by a pthread condition variable. +/* A mutex in lisp is represented by a system condition variable. The system mutex associated with this condition variable is the global lock. @@ -195,17 +195,23 @@ struct thread_state 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; }; commit b3c78ffa31af4fb96cc18da887e2f2a1e68f5e09 Author: Tom Tromey Date: Sat Aug 18 19:59:47 2012 -0600 refactor systhread.h This refactors systhread.h to move the notion of a "lisp mutex" into thread.c. This lets us make make the global lock and post_acquire_global_lock static. diff --git a/src/systhread.c b/src/systhread.c index 968620b..666641c 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -78,67 +78,6 @@ sys_cond_destroy (sys_cond_t *cond) pthread_cond_destroy (cond); } -void -lisp_mutex_init (lisp_mutex_t *mutex) -{ - mutex->owner = NULL; - mutex->count = 0; - /* A lisp "mutex" is really a condition variable. */ - pthread_cond_init (&mutex->condition, NULL); -} - -void -lisp_mutex_lock (lisp_mutex_t *mutex) -{ - struct thread_state *self; - - if (mutex->owner == NULL) - { - mutex->owner = current_thread; - mutex->count = 1; - return; - } - if (mutex->owner == current_thread) - { - ++mutex->count; - return; - } - - self = current_thread; - self->wait_condvar = &mutex->condition; - while (mutex->owner != NULL && EQ (self->error_symbol, Qnil)) - pthread_cond_wait (&mutex->condition, &global_lock); - self->wait_condvar = NULL; - - post_acquire_global_lock (self); - - mutex->owner = self; - mutex->count = 1; -} - -void -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; - - mutex->owner = NULL; - pthread_cond_broadcast (&mutex->condition); - - post_acquire_global_lock (self); -} - -void -lisp_mutex_destroy (lisp_mutex_t *mutex) -{ - sys_cond_destroy (&mutex->condition); -} - sys_thread_t sys_thread_self (void) { diff --git a/src/systhread.h b/src/systhread.h index bf9358c..790b385 100644 --- a/src/systhread.h +++ b/src/systhread.h @@ -23,19 +23,6 @@ along with GNU Emacs. If not, see . */ #include -/* A mutex in lisp is represented by a pthread condition variable. - The pthread mutex associated with this condition variable is the - global lock. - - Using a condition variable lets us implement interruptibility for - lisp mutexes. */ -typedef struct -{ - struct thread_state *owner; - unsigned int count; - pthread_cond_t condition; -} lisp_mutex_t; - /* A system mutex is just a pthread mutex. This is only used for the GIL. */ typedef pthread_mutex_t sys_mutex_t; @@ -64,11 +51,6 @@ extern void sys_cond_signal (sys_cond_t *); extern void sys_cond_broadcast (sys_cond_t *); extern void sys_cond_destroy (sys_cond_t *); -extern void lisp_mutex_init (lisp_mutex_t *); -extern void lisp_mutex_lock (lisp_mutex_t *); -extern void lisp_mutex_unlock (lisp_mutex_t *); -extern void lisp_mutex_destroy (lisp_mutex_t *); - extern sys_thread_t sys_thread_self (void); extern int sys_thread_equal (sys_thread_t, sys_thread_t); diff --git a/src/thread.c b/src/thread.c index e8e43c5..9c39b84 100644 --- a/src/thread.c +++ b/src/thread.c @@ -30,12 +30,119 @@ struct thread_state *current_thread = &primary_thread; static struct thread_state *all_threads = &primary_thread; -sys_mutex_t global_lock; +static sys_mutex_t global_lock; Lisp_Object Qthreadp, Qmutexp; +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; + + if (self != current_thread) + { + unbind_for_thread_switch (); + current_thread = self; + 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 (!EQ (current_thread->error_symbol, Qnil)) + { + 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 void +lisp_mutex_lock (lisp_mutex_t *mutex) +{ + struct thread_state *self; + + if (mutex->owner == NULL) + { + mutex->owner = current_thread; + mutex->count = 1; + return; + } + if (mutex->owner == current_thread) + { + ++mutex->count; + return; + } + + self = current_thread; + self->wait_condvar = &mutex->condition; + while (mutex->owner != NULL && EQ (self->error_symbol, Qnil)) + sys_cond_wait (&mutex->condition, &global_lock); + self->wait_condvar = NULL; + + post_acquire_global_lock (self); + + mutex->owner = self; + mutex->count = 1; +} + +static void +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; + + mutex->owner = NULL; + sys_cond_broadcast (&mutex->condition); + + post_acquire_global_lock (self); +} + +static void +lisp_mutex_destroy (lisp_mutex_t *mutex) +{ + sys_cond_destroy (&mutex->condition); +} + + + DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0, doc: /* Create a mutex. A mutex provides a synchronization point for threads. @@ -146,51 +253,6 @@ finalize_one_mutex (struct Lisp_Mutex *mutex) -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. */ -void -post_acquire_global_lock (struct thread_state *self) -{ - Lisp_Object buffer; - - if (self != current_thread) - { - unbind_for_thread_switch (); - current_thread = self; - 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 (!EQ (current_thread->error_symbol, Qnil)) - { - 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); -} - - - struct select_args { select_func *func; diff --git a/src/thread.h b/src/thread.h index 9db3c79..32ef48f 100644 --- a/src/thread.h +++ b/src/thread.h @@ -187,6 +187,19 @@ struct thread_state struct thread_state *next_thread; }; +/* A mutex in lisp is represented by a pthread 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 +{ + struct thread_state *owner; + unsigned int count; + sys_cond_t condition; +} lisp_mutex_t; + struct Lisp_Mutex { struct vectorlike_header header; @@ -198,9 +211,6 @@ struct Lisp_Mutex extern struct thread_state *current_thread; -extern sys_mutex_t global_lock; -extern void post_acquire_global_lock (struct thread_state *); - extern void unmark_threads (void); extern void finalize_one_thread (struct thread_state *state); extern void finalize_one_mutex (struct Lisp_Mutex *); commit f52cfea0dcea4ae9599d4a775901ca06a0517f56 Author: Tom Tromey Date: Fri Aug 17 07:51:19 2012 -0600 write docstrings for the thread functions diff --git a/src/thread.c b/src/thread.c index e492c57..e8e43c5 100644 --- a/src/thread.c +++ b/src/thread.c @@ -37,7 +37,15 @@ Lisp_Object Qthreadp, Qmutexp; DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0, - doc: /* FIXME */) + 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; @@ -71,18 +79,24 @@ do_unwind_mutex_lock (Lisp_Object ignore) } DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0, - doc: /* FIXME */) - (Lisp_Object obj) -{ - struct Lisp_Mutex *mutex; + 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 (obj); - mutex = XMUTEX (obj); + CHECK_MUTEX (mutex); + lmutex = XMUTEX (mutex); - current_thread->event_object = obj; + current_thread->event_object = mutex; record_unwind_protect (do_unwind_mutex_lock, Qnil); - flush_stack_call_func (mutex_lock_callback, mutex); + flush_stack_call_func (mutex_lock_callback, lmutex); return unbind_to (count, Qnil); } @@ -96,28 +110,32 @@ mutex_unlock_callback (void *arg) } DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0, - doc: /* FIXME */) - (Lisp_Object obj) + 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 *mutex; + struct Lisp_Mutex *lmutex; - CHECK_MUTEX (obj); - mutex = XMUTEX (obj); + CHECK_MUTEX (mutex); + lmutex = XMUTEX (mutex); - flush_stack_call_func (mutex_unlock_callback, mutex); + flush_stack_call_func (mutex_unlock_callback, lmutex); return Qnil; } DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0, - doc: /* FIXME */) - (Lisp_Object obj) + doc: /* Return the name of MUTEX. +If no name was given when MUTEX was created, return nil. */) + (Lisp_Object mutex) { - struct Lisp_Mutex *mutex; + struct Lisp_Mutex *lmutex; - CHECK_MUTEX (obj); - mutex = XMUTEX (obj); + CHECK_MUTEX (mutex); + lmutex = XMUTEX (mutex); - return mutex->name; + return lmutex->name; } void @@ -472,7 +490,11 @@ thread_signal_callback (void *arg) } DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0, - doc: /* FIXME */) + 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' or`thread-join' in +the target thread. */) (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data) { struct thread_state *tstate; @@ -495,7 +517,7 @@ DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0, } DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0, - doc: /* FIXME */) + doc: /* Return t if THREAD is alive, or nil if it has exited. */) (Lisp_Object thread) { struct thread_state *tstate; @@ -509,7 +531,11 @@ DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0, } DEFUN ("thread-blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0, - doc: /* FIXME */) + 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. +Otherwise, if THREAD is not blocked, return nil. */) (Lisp_Object thread) { struct thread_state *tstate; @@ -539,7 +565,9 @@ thread_join_callback (void *arg) } DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0, - doc: /* FIXME */) + 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; @@ -555,7 +583,7 @@ DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0, DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0, doc: /* Return a list of all threads. */) - (void) + (void) { Lisp_Object result = Qnil; struct thread_state *iter; commit abb9e9d865e156bb7ba28063a40a1e54608143b8 Author: Tom Tromey Date: Fri Aug 17 07:16:16 2012 -0600 declare unbind_for_thread_switch and rebind_for_thread_switch in lisp.h diff --git a/src/lisp.h b/src/lisp.h index f0c8318..34ecfe6 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2969,6 +2969,8 @@ extern Lisp_Object internal_condition_case_n extern void specbind (Lisp_Object, Lisp_Object); extern void record_unwind_protect (Lisp_Object (*) (Lisp_Object), Lisp_Object); extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object); +extern void rebind_for_thread_switch (void); +extern void unbind_for_thread_switch (void); extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); extern _Noreturn void verror (const char *, va_list) ATTRIBUTE_FORMAT_PRINTF (1, 0); diff --git a/src/thread.c b/src/thread.c index be98b4a..e492c57 100644 --- a/src/thread.c +++ b/src/thread.c @@ -24,10 +24,6 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "process.h" -/* FIXME */ -extern void unbind_for_thread_switch (void); -extern void rebind_for_thread_switch (void); - static struct thread_state primary_thread; struct thread_state *current_thread = &primary_thread; commit c26c68374458681aff122267af06d75e551bc474 Author: Tom Tromey Date: Wed Aug 15 13:19:48 2012 -0600 add test case for I/O switching diff --git a/test/automated/threads.el b/test/automated/threads.el index b09e269..4c1afbd 100644 --- a/test/automated/threads.el +++ b/test/automated/threads.el @@ -162,4 +162,17 @@ (thread-join thr)) t))) +(defun threads-test-io-switch () + (setq threads-test-global 23)) + +(ert-deftest threads-io-switch () + "test that accept-process-output causes thread switch" + (should + (progn + (setq threads-test-global nil) + (make-thread #'threads-test-io-switch) + (while (not threads-test-global) + (accept-process-output nil 1)) + threads-test-global))) + ;;; threads.el ends here commit 6c0d5ae50789673f53c834084bbe1f62f5a62731 Author: Tom Tromey Date: Wed Aug 15 13:19:24 2012 -0600 process changes This changes wait_reading_process_output to handle threads better. It introduces a wrapper for select that releases the global lock, and it ensures that only a single thread can select a given file descriptor at a time. This also adds the thread-locking feature to processes. By default a process can only have its output accepted by the thread that created it. This can be changed using set-process-thread. (If the thread exits, the process is again available for waiting by any thread.) Note that thread-signal will not currently interrupt a thread blocked on select. I'll fix this later. diff --git a/src/process.c b/src/process.c index 0d33555..ada673e 100644 --- a/src/process.c +++ b/src/process.c @@ -335,6 +335,13 @@ static struct fd_callback_data void *data; /* Flags from enum fd_bits. */ int flags; + /* If this fd is locked to a certain thread, this points to it. + Otherwise, this is NULL. If an fd is locked to a thread, then + only that thread is permitted to wait on it. */ + struct thread_state *thread; + /* If this fd is currently being selected on by a thread, this + points to the thread. Otherwise it is NULL. */ + struct thread_state *waiting_thread; } fd_callback_info[MAXDESC]; @@ -451,8 +458,17 @@ compute_input_wait_mask (SELECT_TYPE *mask) FD_ZERO (mask); for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) { + if (fd_callback_info[fd].thread != NULL + && fd_callback_info[fd].thread != current_thread) + continue; + if (fd_callback_info[fd].waiting_thread != NULL + && fd_callback_info[fd].waiting_thread != current_thread) + continue; if ((fd_callback_info[fd].flags & FOR_READ) != 0) - FD_SET (fd, mask); + { + FD_SET (fd, mask); + fd_callback_info[fd].waiting_thread = current_thread; + } } } @@ -464,9 +480,18 @@ compute_non_process_wait_mask (SELECT_TYPE *mask) FD_ZERO (mask); for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) { + if (fd_callback_info[fd].thread != NULL + && fd_callback_info[fd].thread != current_thread) + continue; + if (fd_callback_info[fd].waiting_thread != NULL + && fd_callback_info[fd].waiting_thread != current_thread) + continue; if ((fd_callback_info[fd].flags & FOR_READ) != 0 && (fd_callback_info[fd].flags & PROCESS_FD) == 0) - FD_SET (fd, mask); + { + FD_SET (fd, mask); + fd_callback_info[fd].waiting_thread = current_thread; + } } } @@ -478,9 +503,18 @@ compute_non_keyboard_wait_mask (SELECT_TYPE *mask) FD_ZERO (mask); for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) { + if (fd_callback_info[fd].thread != NULL + && fd_callback_info[fd].thread != current_thread) + continue; + if (fd_callback_info[fd].waiting_thread != NULL + && fd_callback_info[fd].waiting_thread != current_thread) + continue; if ((fd_callback_info[fd].flags & FOR_READ) != 0 && (fd_callback_info[fd].flags & KEYBOARD_FD) == 0) - FD_SET (fd, mask); + { + FD_SET (fd, mask); + fd_callback_info[fd].waiting_thread = current_thread; + } } } @@ -492,12 +526,31 @@ compute_write_mask (SELECT_TYPE *mask) FD_ZERO (mask); for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) { + if (fd_callback_info[fd].thread != NULL + && fd_callback_info[fd].thread != current_thread) + continue; + if (fd_callback_info[fd].waiting_thread != NULL + && fd_callback_info[fd].waiting_thread != current_thread) + continue; if ((fd_callback_info[fd].flags & FOR_WRITE) != 0) - FD_SET (fd, mask); + { + FD_SET (fd, mask); + fd_callback_info[fd].waiting_thread = current_thread; + } } } +static void +clear_waiting_thread_info (void) +{ + int fd; + for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) + { + if (fd_callback_info[fd].waiting_thread == current_thread) + fd_callback_info[fd].waiting_thread = NULL; + } +} /* Compute the Lisp form of the process status, p->status, from @@ -709,6 +762,7 @@ make_process (Lisp_Object name) Lisp data to nil, so do it only for slots which should not be nil. */ PSET (p, status, Qrun); PSET (p, mark, Fmake_marker ()); + PSET (p, thread, Fcurrent_thread ()); /* Initialize non-Lisp data. Note that allocate_process zeroes out all non-Lisp data, so do it only for slots which should not be zero. */ @@ -746,6 +800,27 @@ remove_process (register Lisp_Object proc) 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; + } + } +} + DEFUN ("processp", Fprocessp, Sprocessp, 1, 1, 0, doc: /* Return t if OBJECT is a process. */) @@ -1094,6 +1169,42 @@ See `set-process-sentinel' for more info on sentinels. */) 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. */) @@ -3993,7 +4104,17 @@ Return non-nil if we received any output before the timeout expired. */) int nsecs; if (! NILP (process)) - CHECK_PROCESS (process); + { + struct Lisp_Process *procp; + + CHECK_PROCESS (process); + procp = XPROCESS (process); + + /* Can't wait for a process that is dedicated to a different + thread. */ + if (!EQ (procp->thread, Qnil) && !EQ (procp->thread, Fcurrent_thread ())) + error ("FIXME"); + } else just_this_one = Qnil; @@ -4249,20 +4370,10 @@ server_accept_connection (Lisp_Object server, int channel) build_string ("\n"))); } -/* 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 Lisp_Object wait_reading_process_output_unwind (Lisp_Object data) { + clear_waiting_thread_info (); waiting_for_user_input_p = XINT (data); return Qnil; } @@ -4329,6 +4440,10 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, int got_some_input = 0; ptrdiff_t count = SPECPDL_INDEX (); + eassert (wait_proc == NULL + || EQ (wait_proc->thread, Qnil) + || XTHREAD (wait_proc->thread) == current_thread); + FD_ZERO (&Available); FD_ZERO (&Writeok); @@ -4484,14 +4599,15 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, compute_write_mask (&Ctemp); timeout = make_emacs_time (0, 0); - if ((pselect (max (max_process_desc, max_input_desc) + 1, - &Atemp, + if ((thread_select (pselect, + max (max_process_desc, max_input_desc) + 1, + &Atemp, #ifdef NON_BLOCKING_CONNECT - (num_pending_connects > 0 ? &Ctemp : NULL), + (num_pending_connects > 0 ? &Ctemp : NULL), #else - NULL, + NULL, #endif - NULL, &timeout, NULL) + NULL, &timeout, NULL) <= 0)) { /* It's okay for us to do this and then continue with @@ -4639,17 +4755,18 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, process_output_skip = 0; } #endif + nfds = thread_select ( #if defined (USE_GTK) || defined (HAVE_GCONF) || defined (HAVE_GSETTINGS) - nfds = xg_select + xg_select #elif defined (HAVE_NS) - nfds = ns_select + ns_select #else - nfds = pselect + pselect #endif - (max (max_process_desc, max_input_desc) + 1, - &Available, - (check_write ? &Writeok : (SELECT_TYPE *)0), - NULL, &timeout, NULL); + , max (max_process_desc, max_input_desc) + 1, + &Available, + (check_write ? &Writeok : (SELECT_TYPE *)0), + NULL, &timeout, NULL); #ifdef HAVE_GNUTLS /* GnuTLS buffers data internally. In lowat mode it leaves @@ -7597,6 +7714,8 @@ The variable takes effect when `start-process' is called. */); defsubr (&Sprocess_filter); defsubr (&Sset_process_sentinel); defsubr (&Sprocess_sentinel); + defsubr (&Sset_process_thread); + defsubr (&Sprocess_thread); defsubr (&Sset_process_window_size); defsubr (&Sset_process_inherit_coding_system_flag); defsubr (&Sset_process_query_on_exit_flag); diff --git a/src/process.h b/src/process.h index 43cc7ea..1ddfe91 100644 --- a/src/process.h +++ b/src/process.h @@ -103,6 +103,9 @@ struct Lisp_Process Lisp_Object gnutls_cred_type; #endif + /* The thread a process is linked to, or nil for any thread. */ + Lisp_Object thread; + /* After this point, there are no Lisp_Objects any more. */ /* alloc.c assumes that `pid' is the first such non-Lisp slot. */ @@ -208,3 +211,5 @@ extern void add_read_fd (int fd, fd_callback func, void *data); extern void delete_read_fd (int fd); extern void add_write_fd (int fd, fd_callback func, void *data); extern void delete_write_fd (int fd); + +extern void update_processes_for_thread_death (Lisp_Object); diff --git a/src/thread.c b/src/thread.c index 40c8be9..be98b4a 100644 --- a/src/thread.c +++ b/src/thread.c @@ -22,6 +22,7 @@ along with GNU Emacs. If not, see . */ #include "lisp.h" #include "character.h" #include "buffer.h" +#include "process.h" /* FIXME */ extern void unbind_for_thread_switch (void); @@ -176,6 +177,50 @@ acquire_global_lock (struct thread_state *self) +struct select_args +{ + select_func *func; + int max_fds; + SELECT_TYPE *rfds; + SELECT_TYPE *wfds; + SELECT_TYPE *efds; + EMACS_TIME *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, SELECT_TYPE *rfds, + SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *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) { @@ -315,6 +360,8 @@ run_thread (void *state) unbind_for_thread_switch (); + update_processes_for_thread_death (Fcurrent_thread ()); + /* Unlink this thread from the list of all threads. */ for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread) ; diff --git a/src/thread.h b/src/thread.h index d21887a..9db3c79 100644 --- a/src/thread.h +++ b/src/thread.h @@ -21,6 +21,9 @@ along with GNU Emacs. If not, see . */ #include "regex.h" +#include "sysselect.h" /* FIXME */ +#include "systime.h" /* FIXME */ + struct thread_state { struct vectorlike_header header; @@ -156,6 +159,18 @@ struct thread_state /*re_char*/ unsigned char *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; @@ -194,4 +209,11 @@ extern void init_threads_once (void); extern void init_threads (void); extern void syms_of_threads (void); +typedef int select_func (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *, + EMACS_TIME *, sigset_t *); + +int thread_select (select_func *func, int max_fds, SELECT_TYPE *rfds, + SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *timeout, + sigset_t *sigmask); + #endif /* THREAD_H */ commit aa14ccd1e2edec2735f9200a4f2e5eee3b0abe09 Author: Tom Tromey Date: Wed Aug 15 13:17:37 2012 -0600 Prepare process.c for threads by not having global select masks. The next step is to make it so selects can choose fds by thread. diff --git a/src/process.c b/src/process.c index 2a61b6d..0d33555 100644 --- a/src/process.c +++ b/src/process.c @@ -267,29 +267,7 @@ static void create_pty (Lisp_Object); static Lisp_Object get_process (register Lisp_Object name); static void exec_sentinel (Lisp_Object proc, Lisp_Object reason); -/* Mask of bits indicating the descriptors that we wait for input on. */ - -static SELECT_TYPE input_wait_mask; - -/* Mask that excludes keyboard input descriptor(s). */ - -static SELECT_TYPE non_keyboard_wait_mask; - -/* Mask that excludes process input descriptor(s). */ - -static SELECT_TYPE non_process_wait_mask; - -/* Mask for selecting for write. */ - -static SELECT_TYPE write_mask; - #ifdef NON_BLOCKING_CONNECT -/* 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 SELECT_TYPE connect_wait_mask; - /* Number of bits set in connect_wait_mask. */ static int num_pending_connects; #endif /* NON_BLOCKING_CONNECT */ @@ -336,13 +314,27 @@ static int pty_max_bytes; +enum fd_bits +{ + /* Read from file descriptor. */ + FOR_READ = 1, + /* Write to file descriptor. */ + FOR_WRITE = 2, + /* This descriptor refers to a keyboard. Only valid if FOR_READ is + set. */ + KEYBOARD_FD = 4, + /* This descriptor refers to a process. */ + PROCESS_FD = 8, + /* A non-blocking connect. Only valid if FOR_WRITE is set. */ + NON_BLOCKING_CONNECT_FD = 16 +}; + static struct fd_callback_data { fd_callback func; void *data; -#define FOR_READ 1 -#define FOR_WRITE 2 - int condition; /* mask of the defines above. */ + /* Flags from enum fd_bits. */ + int flags; } fd_callback_info[MAXDESC]; @@ -357,7 +349,23 @@ add_read_fd (int fd, fd_callback func, void *data) fd_callback_info[fd].func = func; fd_callback_info[fd].data = data; - fd_callback_info[fd].condition |= FOR_READ; +} + +void +add_non_keyboard_read_fd (int fd) +{ + eassert (fd >= 0 && fd < MAXDESC); + eassert (fd_callback_info[fd].func == NULL); + fd_callback_info[fd].flags |= FOR_READ; + if (fd > max_input_desc) + max_input_desc = fd; +} + +void +add_process_read_fd (int fd) +{ + add_non_keyboard_read_fd (fd); + fd_callback_info[fd].flags |= PROCESS_FD; } /* Stop monitoring file descriptor FD for when read is possible. */ @@ -368,8 +376,7 @@ delete_read_fd (int fd) eassert (fd < MAXDESC); delete_keyboard_wait_descriptor (fd); - fd_callback_info[fd].condition &= ~FOR_READ; - if (fd_callback_info[fd].condition == 0) + if (fd_callback_info[fd].flags == 0) { fd_callback_info[fd].func = 0; fd_callback_info[fd].data = 0; @@ -383,13 +390,24 @@ void add_write_fd (int fd, fd_callback func, void *data) { eassert (fd < MAXDESC); - FD_SET (fd, &write_mask); if (fd > max_input_desc) max_input_desc = fd; 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; +} + +void +add_non_blocking_write_fd (int fd) +{ + eassert (fd >= 0 && fd < MAXDESC); + eassert (fd_callback_info[fd].func == NULL); + + fd_callback_info[fd].flags |= FOR_WRITE | NON_BLOCKING_CONNECT_FD; + if (fd > max_input_desc) + max_input_desc = fd; + ++num_pending_connects; } /* Stop monitoring file descriptor FD for when write is possible. */ @@ -400,24 +418,87 @@ delete_write_fd (int fd) int lim = max_input_desc; eassert (fd < MAXDESC); - FD_CLR (fd, &write_mask); - fd_callback_info[fd].condition &= ~FOR_WRITE; - if (fd_callback_info[fd].condition == 0) + if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0) + { + if (--num_pending_connects < 0) + abort (); + } + 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; if (fd == max_input_desc) - for (fd = lim; fd >= 0; fd--) - if (FD_ISSET (fd, &input_wait_mask) || FD_ISSET (fd, &write_mask)) - { - max_input_desc = fd; - break; - } + { + for (fd = max_input_desc; fd >= 0; --fd) + { + if (fd_callback_info[fd].flags != 0) + { + max_input_desc = fd; + break; + } + } + } + } +} + +static void +compute_input_wait_mask (SELECT_TYPE *mask) +{ + int fd; + FD_ZERO (mask); + for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) + { + if ((fd_callback_info[fd].flags & FOR_READ) != 0) + FD_SET (fd, mask); } } +static void +compute_non_process_wait_mask (SELECT_TYPE *mask) +{ + int fd; + + FD_ZERO (mask); + for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) + { + if ((fd_callback_info[fd].flags & FOR_READ) != 0 + && (fd_callback_info[fd].flags & PROCESS_FD) == 0) + FD_SET (fd, mask); + } +} + +static void +compute_non_keyboard_wait_mask (SELECT_TYPE *mask) +{ + int fd; + + FD_ZERO (mask); + for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) + { + if ((fd_callback_info[fd].flags & FOR_READ) != 0 + && (fd_callback_info[fd].flags & KEYBOARD_FD) == 0) + FD_SET (fd, mask); + } +} + +static void +compute_write_mask (SELECT_TYPE *mask) +{ + int fd; + + FD_ZERO (mask); + for (fd = 0; fd < max (max_process_desc, max_input_desc); ++fd) + { + if ((fd_callback_info[fd].flags & FOR_WRITE) != 0) + FD_SET (fd, mask); + } +} + + + /* Compute the Lisp form of the process status, p->status, from the numeric status that was returned by `wait'. */ @@ -961,17 +1042,11 @@ The string argument is normally a multibyte string, except: if (p->infd >= 0) { if (EQ (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); - } + delete_read_fd (p->infd); } PSET (p, filter, filter); @@ -1650,10 +1725,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) #endif /* HAVE_WORKING_VFORK */ pthread_sigmask (SIG_BLOCK, &blocked, &procmask); - FD_SET (inchannel, &input_wait_mask); - FD_SET (inchannel, &non_keyboard_wait_mask); - if (inchannel > max_process_desc) - max_process_desc = inchannel; + add_non_keyboard_read_fd (inchannel); /* Until we store the proper pid, enable sigchld_handler to recognize an unknown pid as standing for this process. @@ -1968,10 +2040,7 @@ create_pty (Lisp_Object process) PSET (XPROCESS (process), status, Qrun); setup_process_coding_systems (process); - FD_SET (inchannel, &input_wait_mask); - FD_SET (inchannel, &non_keyboard_wait_mask); - if (inchannel > max_process_desc) - max_process_desc = inchannel; + add_non_keyboard_read_fd (inchannel); XPROCESS (process)->pid = -2; #ifdef HAVE_PTYS @@ -2616,10 +2685,7 @@ usage: (make-serial-process &rest ARGS) */) p->pty_flag = 0; if (!EQ (p->command, Qt)) - { - FD_SET (fd, &input_wait_mask); - FD_SET (fd, &non_keyboard_wait_mask); - } + add_non_keyboard_read_fd (fd); if (BUFFERP (buffer)) { @@ -3431,12 +3497,8 @@ usage: (make-network-process &rest ARGS) */) in that case, we still need to signal this like a non-blocking connection. */ PSET (p, status, Qconnect); - 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 #endif @@ -3444,10 +3506,7 @@ usage: (make-network-process &rest ARGS) */) 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; @@ -3892,16 +3951,10 @@ deactivate_process (Lisp_Object proc) } #endif chan_process[inchannel] = Qnil; - FD_CLR (inchannel, &input_wait_mask); - FD_CLR (inchannel, &non_keyboard_wait_mask); + delete_read_fd (inchannel); #ifdef NON_BLOCKING_CONNECT - if (FD_ISSET (inchannel, &connect_wait_mask)) - { - FD_CLR (inchannel, &connect_wait_mask); - FD_CLR (inchannel, &write_mask); - if (--num_pending_connects < 0) - abort (); - } + if ((fd_callback_info[inchannel].flags & NON_BLOCKING_CONNECT_FD) != 0) + delete_write_fd (inchannel); #endif if (inchannel == max_process_desc) { @@ -4165,13 +4218,7 @@ server_accept_connection (Lisp_Object server, int channel) /* Client processes for accepted connections are not stopped initially. */ if (!EQ (p->filter, Qt)) - { - FD_SET (s, &input_wait_mask); - FD_SET (s, &non_keyboard_wait_mask); - } - - if (s > max_process_desc) - max_process_desc = s; + add_non_keyboard_read_fd (s); /* Setup coding system for new process based on server process. This seems to be the proper thing to do, as the coding system @@ -4433,8 +4480,8 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, 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_emacs_time (0, 0); if ((pselect (max (max_process_desc, max_input_desc) + 1, @@ -4512,17 +4559,17 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } else if (!NILP (wait_for_cell)) { - Available = non_process_wait_mask; + compute_non_process_wait_mask (&Available); check_delay = 0; check_write = 0; } else { if (! read_kbd) - Available = non_keyboard_wait_mask; + compute_non_keyboard_wait_mask (&Available); else - Available = input_wait_mask; - Writeok = write_mask; + compute_input_wait_mask (&Available); + compute_write_mask (&Writeok); #ifdef SELECT_CANT_DO_WRITE_MASK check_write = 0; #else @@ -4790,19 +4837,19 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, struct fd_callback_data *d = &fd_callback_info[channel]; if (FD_ISSET (channel, &Available) && d->func != 0 - && (d->condition & FOR_READ) != 0) + && (d->flags & FOR_READ) != 0) d->func (channel, d->data, 1); if (FD_ISSET (channel, &Writeok) && d->func != 0 - && (d->condition & FOR_WRITE) != 0) + && (d->flags & FOR_WRITE) != 0) d->func (channel, d->data, 0); } for (channel = 0; channel <= max_process_desc; channel++) { if (FD_ISSET (channel, &Available) - && FD_ISSET (channel, &non_keyboard_wait_mask) - && !FD_ISSET (channel, &non_process_wait_mask)) + && ((fd_callback_info[channel].flags & (KEYBOARD_FD | PROCESS_FD)) + == PROCESS_FD)) { int nread; @@ -4880,8 +4927,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, /* Clear the descriptor now, so we only raise the signal once. */ - FD_CLR (channel, &input_wait_mask); - FD_CLR (channel, &non_keyboard_wait_mask); + delete_read_fd (channel); if (p->pid == -2) { @@ -4915,14 +4961,12 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } #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; - FD_CLR (channel, &connect_wait_mask); - FD_CLR (channel, &write_mask); - if (--num_pending_connects < 0) - abort (); + delete_write_fd (channel); proc = chan_process[channel]; if (NILP (proc)) @@ -4970,10 +5014,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, from the process before calling the sentinel. */ exec_sentinel (proc, build_string ("open\n")); if (!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 */ @@ -6014,10 +6055,7 @@ traffic. */) p = XPROCESS (process); if (NILP (p->command) && p->infd >= 0) - { - FD_CLR (p->infd, &input_wait_mask); - FD_CLR (p->infd, &non_keyboard_wait_mask); - } + delete_read_fd (p->infd); PSET (p, command, Qt); return process; } @@ -6045,8 +6083,7 @@ traffic. */) && p->infd >= 0 && (!EQ (p->filter, Qt) || EQ (p->status, Qlisten))) { - FD_SET (p->infd, &input_wait_mask); - FD_SET (p->infd, &non_keyboard_wait_mask); + add_non_keyboard_read_fd (p->infd); #ifdef WINDOWSNT if (fd_info[ p->infd ].flags & FILE_SERIAL) PurgeComm (fd_info[ p->infd ].hnd, PURGE_RXABORT | PURGE_RXCLEAR); @@ -6419,10 +6456,7 @@ sigchld_handler (int signo) /* We use clear_desc_flag to avoid a compiler bug in Microsoft C. */ if (clear_desc_flag) - { - FD_CLR (p->infd, &input_wait_mask); - FD_CLR (p->infd, &non_keyboard_wait_mask); - } + delete_read_fd (p->infd); /* Tell wait_reading_process_output that it needs to wake up and look around. */ @@ -6796,8 +6830,8 @@ keyboard_bit_set (fd_set *mask) int fd; for (fd = 0; fd <= max_input_desc; fd++) - if (FD_ISSET (fd, mask) && FD_ISSET (fd, &input_wait_mask) - && !FD_ISSET (fd, &non_keyboard_wait_mask)) + if (FD_ISSET (fd, mask) + && ((fd_callback_info[fd].flags & KEYBOARD_FD) != 0)) return 1; return 0; @@ -7042,8 +7076,8 @@ void add_keyboard_wait_descriptor (int desc) { #ifdef subprocesses /* actually means "not MSDOS" */ - FD_SET (desc, &input_wait_mask); - FD_SET (desc, &non_process_wait_mask); + eassert (desc >= 0 && desc < MAXDESC); + fd_callback_info[desc].flags |= FOR_READ | KEYBOARD_FD; if (desc > max_input_desc) max_input_desc = desc; #endif @@ -7058,13 +7092,19 @@ delete_keyboard_wait_descriptor (int desc) int fd; int lim = max_input_desc; - FD_CLR (desc, &input_wait_mask); - FD_CLR (desc, &non_process_wait_mask); + fd_callback_info[desc].flags &= ~(FOR_READ | KEYBOARD_FD | PROCESS_FD); if (desc == max_input_desc) - for (fd = 0; fd < lim; fd++) - if (FD_ISSET (fd, &input_wait_mask) || FD_ISSET (fd, &write_mask)) - max_input_desc = fd; + { + for (fd = max_input_desc; fd >= 0; --fd) + { + if (fd_callback_info[desc].flags != 0) + { + max_input_desc = fd; + break; + } + } + } #endif } @@ -7320,15 +7360,10 @@ init_process_emacs (void) signal (SIGCHLD, sigchld_handler); #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 = 0; memset (fd_callback_info, 0, sizeof (fd_callback_info)); #ifdef NON_BLOCKING_CONNECT - FD_ZERO (&connect_wait_mask); num_pending_connects = 0; #endif commit 0ccc5d8998a62c3e137f798e1e2b7f8362f12a85 Author: Tom Tromey Date: Wed Aug 15 13:17:05 2012 -0600 fix a latent bug in process.c * process.c (wait_reading_process_output): Check Writeok bits, not write_mask. diff --git a/src/process.c b/src/process.c index a43655e..2a61b6d 100644 --- a/src/process.c +++ b/src/process.c @@ -4792,7 +4792,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, && d->func != 0 && (d->condition & FOR_READ) != 0) d->func (channel, d->data, 1); - if (FD_ISSET (channel, &write_mask) + if (FD_ISSET (channel, &Writeok) && d->func != 0 && (d->condition & FOR_WRITE) != 0) d->func (channel, d->data, 0); commit dbb33d4e99cc9d68dea0b1c137afdb9f19121022 Author: Tom Tromey Date: Wed Aug 15 13:16:33 2012 -0600 This adds thread-blocker, a function to examine what a thread is blocked on. I thought this would be another nice debugging addition. diff --git a/src/thread.c b/src/thread.c index 9ec418f..40c8be9 100644 --- a/src/thread.c +++ b/src/thread.c @@ -66,17 +66,27 @@ mutex_lock_callback (void *arg) lisp_mutex_lock (&mutex->mutex); } +static Lisp_Object +do_unwind_mutex_lock (Lisp_Object ignore) +{ + current_thread->event_object = Qnil; + return Qnil; +} + DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0, doc: /* FIXME */) (Lisp_Object obj) { struct Lisp_Mutex *mutex; + ptrdiff_t count = SPECPDL_INDEX (); CHECK_MUTEX (obj); mutex = XMUTEX (obj); + current_thread->event_object = obj; + record_unwind_protect (do_unwind_mutex_lock, Qnil); flush_stack_call_func (mutex_lock_callback, mutex); - return Qnil; + return unbind_to (count, Qnil); } static void @@ -361,6 +371,7 @@ If NAME is given, it names the new thread. */) 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 (new_thread->m_specpdl_size @@ -454,17 +465,33 @@ DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0, return tstate->m_specpdl == NULL ? Qnil : Qt; } +DEFUN ("thread-blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0, + doc: /* FIXME */) + (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 (tstate->m_specpdl != NULL && EQ (self->error_symbol, Qnil)) sys_cond_wait (self->wait_condvar, &global_lock); self->wait_condvar = NULL; + self->event_object = Qnil; post_acquire_global_lock (self); } @@ -515,6 +542,7 @@ init_primary_thread (void) primary_thread.function = Qnil; primary_thread.error_symbol = Qnil; primary_thread.error_data = Qnil; + primary_thread.event_object = Qnil; sys_cond_init (&primary_thread.thread_condvar); } @@ -544,6 +572,7 @@ syms_of_threads (void) defsubr (&Sthread_signal); defsubr (&Sthread_alive_p); defsubr (&Sthread_join); + defsubr (&Sthread_blocker); defsubr (&Sall_threads); defsubr (&Smake_mutex); defsubr (&Smutex_lock); diff --git a/src/thread.h b/src/thread.h index 1a193b1..d21887a 100644 --- a/src/thread.h +++ b/src/thread.h @@ -44,6 +44,10 @@ struct thread_state 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_gcprolist must be the first non-lisp field. */ /* Recording what needs to be marked for gc. */ struct gcpro *m_gcprolist; commit 8d3566c6a0eb3977c3115ae100a357f8d63cf77e Author: Tom Tromey Date: Wed Aug 15 13:14:14 2012 -0600 This adds names to mutexes. This seemed like a nice debugging extension. diff --git a/src/print.c b/src/print.c index 42e7241..b14a769 100644 --- a/src/print.c +++ b/src/print.c @@ -1957,10 +1957,14 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag } else if (MUTEXP (obj)) { - int len; strout ("#name)) + print_string (XMUTEX (obj)->name, printcharfun); + else + { + int len = sprintf (buf, "%p", XMUTEX (obj)); + strout (buf, len, len, printcharfun); + } PRINTCHAR ('>'); } else diff --git a/src/thread.c b/src/thread.c index 80557e5..9ec418f 100644 --- a/src/thread.c +++ b/src/thread.c @@ -39,16 +39,9 @@ Lisp_Object Qthreadp, Qmutexp; -struct Lisp_Mutex -{ - struct vectorlike_header header; - - lisp_mutex_t mutex; -}; - -DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 0, 0, +DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0, doc: /* FIXME */) - (void) + (Lisp_Object name) { struct Lisp_Mutex *mutex; Lisp_Object result; @@ -57,6 +50,7 @@ DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 0, 0, 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); @@ -107,6 +101,18 @@ DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0, return Qnil; } +DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0, + doc: /* FIXME */) + (Lisp_Object obj) +{ + struct Lisp_Mutex *mutex; + + CHECK_MUTEX (obj); + mutex = XMUTEX (obj); + + return mutex->name; +} + void finalize_one_mutex (struct Lisp_Mutex *mutex) { @@ -542,6 +548,7 @@ syms_of_threads (void) defsubr (&Smake_mutex); defsubr (&Smutex_lock); defsubr (&Smutex_unlock); + defsubr (&Smutex_name); Qthreadp = intern_c_string ("threadp"); staticpro (&Qthreadp); diff --git a/src/thread.h b/src/thread.h index d3ec38a..1a193b1 100644 --- a/src/thread.h +++ b/src/thread.h @@ -168,7 +168,14 @@ struct thread_state struct thread_state *next_thread; }; -struct Lisp_Mutex; +struct Lisp_Mutex +{ + struct vectorlike_header header; + + Lisp_Object name; + + lisp_mutex_t mutex; +}; extern struct thread_state *current_thread; commit fc196ac95224330384227da8f5706631701e3610 Author: Tom Tromey Date: Wed Aug 15 13:11:54 2012 -0600 This adds some tests of the threading code. diff --git a/test/automated/threads.el b/test/automated/threads.el new file mode 100644 index 0000000..b09e269 --- /dev/null +++ b/test/automated/threads.el @@ -0,0 +1,165 @@ +;;; threads.el --- tests for threads. + +;; Copyright (C) 2012 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 . + +;;; Code: + +(ert-deftest threads-is-one () + "test for existence of a thread" + (should (current-thread))) + +(ert-deftest threads-threadp () + "test of threadp" + (should (threadp (current-thread)))) + +(ert-deftest threads-type () + "test of thread type" + (should (eq (type-of (current-thread)) 'thread))) + +(ert-deftest threads-name () + "test for name of a thread" + (should + (string= "hi bob" (thread-name (make-thread #'ignore "hi bob"))))) + +(ert-deftest threads-alive () + "test for thread liveness" + (should + (thread-alive-p (make-thread #'ignore)))) + +(ert-deftest threads-all-threads () + "simple test for all-threads" + (should (listp (all-threads)))) + +(defvar threads-test-global nil) + +(defun threads-test-thread1 () + (setq threads-test-global 23)) + +(ert-deftest threads-basic () + "basic thread test" + (should + (progn + (setq threads-test-global nil) + (make-thread #'threads-test-thread1) + (while (not threads-test-global) + (thread-yield)) + threads-test-global))) + +(ert-deftest threads-join () + "test of thread-join" + (should + (progn + (setq threads-test-global nil) + (let ((thread (make-thread #'threads-test-thread1))) + (thread-join thread) + (and threads-test-global + (not (thread-alive-p thread))))))) + +(defvar threads-test-binding nil) + +(defun threads-test-thread2 () + (let ((threads-test-binding 23)) + (thread-yield)) + (setq threads-test-global 23)) + +(ert-deftest threads-let-binding () + "simple test of threads and let bindings" + (should + (progn + (setq threads-test-binding nil) + (make-thread #'threads-test-thread2) + (while (not threads-test-global) + (thread-yield)) + (and (not threads-test-binding) + threads-test-global)))) + +(ert-deftest threads-mutexp () + "simple test of mutexp" + (should-not (mutexp 'hi))) + +(ert-deftest threads-mutexp-2 () + "another simple test of mutexp" + (should (mutexp (make-mutex)))) + +(ert-deftest threads-mutex-type () + "type-of mutex" + (should (eq (type-of (make-mutex)) 'mutex))) + +(ert-deftest threads-mutex-lock-unlock () + "test mutex-lock and unlock" + (should + (let ((mx (make-mutex))) + (mutex-lock mx) + (mutex-unlock mx) + t))) + +(ert-deftest threads-mutex-recursive () + "test mutex-lock and unlock" + (should + (let ((mx (make-mutex))) + (mutex-lock mx) + (mutex-lock mx) + (mutex-unlock mx) + (mutex-unlock mx) + t))) + +(defvar threads-mutex nil) +(defvar threads-mutex-key nil) + +(defun threads-test-mlock () + (mutex-lock threads-mutex) + (setq threads-mutex-key 23) + (while threads-mutex-key + (thread-yield)) + (mutex-unlock threads-mutex)) + +(ert-deftest threads-mutex-contention () + "test of mutex contention" + (should + (progn + (setq threads-mutex (make-mutex)) + (setq threads-mutex-key nil) + (make-thread #'threads-test-mlock) + ;; Wait for other thread to get the lock. + (while (not threads-mutex-key) + (thread-yield)) + ;; Try now. + (setq threads-mutex-key nil) + (mutex-lock threads-mutex) + (mutex-unlock threads-mutex) + t))) + +(defun threads-test-mlock2 () + (setq threads-mutex-key 23) + (mutex-lock threads-mutex)) + +(ert-deftest threads-mutex-signal () + "test signalling a blocked thread" + (should + (progn + (setq threads-mutex (make-mutex)) + (setq threads-mutex-key nil) + (mutex-lock threads-mutex) + (let ((thr (make-thread #'threads-test-mlock2))) + (while (not threads-mutex-key) + (thread-yield)) + (thread-signal thr 'quit nil) + (thread-join thr)) + t))) + +;;; threads.el ends here commit 51100bb8d36f68842ab55fd0501af56dfc58cc51 Author: Tom Tromey Date: Wed Aug 15 13:11:22 2012 -0600 This supplies the mutex implementation for Emacs Lisp. A lisp mutex is implemented using a condition variable, so that we can interrupt a mutex-lock operation by calling thread-signal on the blocking thread. I did things this way because pthread_mutex_lock can't readily be interrupted. diff --git a/src/alloc.c b/src/alloc.c index 69742a3..80d22d6 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3104,6 +3104,8 @@ sweep_vectors (void) if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD)) finalize_one_thread ((struct thread_state *) vector); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX)) + finalize_one_mutex ((struct Lisp_Mutex *) vector); next = ADVANCE (vector, nbytes); diff --git a/src/data.c b/src/data.c index fd2194f..b47c2d1 100644 --- a/src/data.c +++ b/src/data.c @@ -94,7 +94,7 @@ static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; static Lisp_Object Qsubrp, Qmany, Qunevalled; Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; static Lisp_Object Qdefun; -Lisp_Object Qthread; +Lisp_Object Qthread, Qmutex; Lisp_Object Qinteractive_form; @@ -214,6 +214,8 @@ for example, (type-of 1) returns `integer'. */) return Qfont_object; if (THREADP (object)) return Qthread; + if (MUTEXP (object)) + return Qmutex; return Qvector; case Lisp_Float: @@ -471,6 +473,15 @@ DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0, return Qnil; } +DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0, + doc: /* Return t if OBJECT is a mutex. */) + (Lisp_Object object) +{ + if (MUTEXP (object)) + return Qt; + else + return Qnil; +} /* Extract and set components of lists */ @@ -3105,6 +3116,7 @@ syms_of_data (void) DEFSYM (Qbool_vector, "bool-vector"); DEFSYM (Qhash_table, "hash-table"); DEFSYM (Qthread, "thread"); + DEFSYM (Qmutex, "mutex"); /* Used by Fgarbage_collect. */ DEFSYM (Qinterval, "interval"); DEFSYM (Qmisc, "misc"); @@ -3148,6 +3160,7 @@ syms_of_data (void) defsubr (&Sbyte_code_function_p); defsubr (&Schar_or_string_p); defsubr (&Sthreadp); + defsubr (&Smutexp); defsubr (&Scar); defsubr (&Scdr); defsubr (&Scar_safe); diff --git a/src/lisp.h b/src/lisp.h index 52a5232..f0c8318 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -366,6 +366,7 @@ enum pvec_type PVEC_SUBR, PVEC_OTHER, PVEC_THREAD, + PVEC_MUTEX, /* These last 4 are special because we OR them in fns.c:internal_equal, so they have to use a disjoint bit pattern: if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE @@ -555,6 +556,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) ((struct Lisp_Bool_Vector *) \ XUNTAG (a, Lisp_Vectorlike))) #define XTHREAD(a) (eassert (THREADP (a)), (struct thread_state *) XPNTR(a)) +#define XMUTEX(a) (eassert (MUTEXP (a)), (struct Lisp_Mutex *) XPNTR(a)) /* Construct a Lisp_Object from a value or address. */ @@ -606,6 +608,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) #define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE)) #define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD)) +#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX)) /* Convenience macros for dealing with Lisp arrays. */ @@ -1705,6 +1708,7 @@ typedef struct { #define BOOL_VECTOR_P(x) PSEUDOVECTORP (x, PVEC_BOOL_VECTOR) #define FRAMEP(x) PSEUDOVECTORP (x, PVEC_FRAME) #define THREADP(x) PSEUDOVECTORP (x, PVEC_THREAD) +#define MUTEXP(x) PSEUDOVECTORP (x, PVEC_MUTEX) /* Test for image (image . spec) */ #define IMAGEP(x) (CONSP (x) && EQ (XCAR (x), Qimage)) @@ -1826,6 +1830,9 @@ typedef struct { #define CHECK_THREAD(x) \ CHECK_TYPE (THREADP (x), Qthreadp, x) +#define CHECK_MUTEX(x) \ + CHECK_TYPE (MUTEXP (x), Qmutexp, x) + /* Since we can't assign directly to the CAR or CDR fields of a cons cell, use these when checking that those fields contain numbers. */ #define CHECK_NUMBER_CAR(x) \ @@ -2448,7 +2455,7 @@ extern Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp; extern Lisp_Object Qbuffer_or_string_p; extern Lisp_Object Qfboundp; extern Lisp_Object Qchar_table_p, Qvector_or_char_table_p; -extern Lisp_Object Qthreadp; +extern Lisp_Object Qthreadp, Qmutexp; extern Lisp_Object Qcdr; diff --git a/src/print.c b/src/print.c index 4537521..42e7241 100644 --- a/src/print.c +++ b/src/print.c @@ -1955,6 +1955,14 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag } PRINTCHAR ('>'); } + else if (MUTEXP (obj)) + { + int len; + strout ("#'); + } else { ptrdiff_t size = ASIZE (obj); diff --git a/src/thread.c b/src/thread.c index 5da2e10..80557e5 100644 --- a/src/thread.c +++ b/src/thread.c @@ -35,7 +35,83 @@ static struct thread_state *all_threads = &primary_thread; sys_mutex_t global_lock; -Lisp_Object Qthreadp; +Lisp_Object Qthreadp, Qmutexp; + + + +struct Lisp_Mutex +{ + struct vectorlike_header header; + + lisp_mutex_t mutex; +}; + +DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 0, 0, + doc: /* FIXME */) + (void) +{ + struct Lisp_Mutex *mutex; + Lisp_Object result; + + 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)); + lisp_mutex_init (&mutex->mutex); + + XSETMUTEX (result, mutex); + return result; +} + +static void +mutex_lock_callback (void *arg) +{ + struct Lisp_Mutex *mutex = arg; + + /* This calls post_acquire_global_lock. */ + lisp_mutex_lock (&mutex->mutex); +} + +DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0, + doc: /* FIXME */) + (Lisp_Object obj) +{ + struct Lisp_Mutex *mutex; + + CHECK_MUTEX (obj); + mutex = XMUTEX (obj); + + flush_stack_call_func (mutex_lock_callback, mutex); + return Qnil; +} + +static void +mutex_unlock_callback (void *arg) +{ + struct Lisp_Mutex *mutex = arg; + + /* This calls post_acquire_global_lock. */ + lisp_mutex_unlock (&mutex->mutex); +} + +DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0, + doc: /* FIXME */) + (Lisp_Object obj) +{ + struct Lisp_Mutex *mutex; + + CHECK_MUTEX (obj); + mutex = XMUTEX (obj); + + flush_stack_call_func (mutex_unlock_callback, mutex); + return Qnil; +} + +void +finalize_one_mutex (struct Lisp_Mutex *mutex) +{ + lisp_mutex_destroy (&mutex->mutex); +} @@ -463,7 +539,12 @@ syms_of_threads (void) defsubr (&Sthread_alive_p); defsubr (&Sthread_join); defsubr (&Sall_threads); + defsubr (&Smake_mutex); + defsubr (&Smutex_lock); + defsubr (&Smutex_unlock); Qthreadp = intern_c_string ("threadp"); staticpro (&Qthreadp); + Qmutexp = intern_c_string ("mutexp"); + staticpro (&Qmutexp); } diff --git a/src/thread.h b/src/thread.h index 3b53331..d3ec38a 100644 --- a/src/thread.h +++ b/src/thread.h @@ -168,6 +168,8 @@ struct thread_state struct thread_state *next_thread; }; +struct Lisp_Mutex; + extern struct thread_state *current_thread; extern sys_mutex_t global_lock; @@ -175,6 +177,7 @@ extern void post_acquire_global_lock (struct thread_state *); extern void unmark_threads (void); extern void finalize_one_thread (struct thread_state *state); +extern void finalize_one_mutex (struct Lisp_Mutex *); extern void init_threads_once (void); extern void init_threads (void); commit 1dcacbc64721b1a4de58aa36460b0a39e766be63 Author: Tom Tromey Date: Wed Aug 15 13:09:32 2012 -0600 This adds most of the thread features visible to emacs lisp. I roughly followed the Bordeaux threads API: http://trac.common-lisp.net/bordeaux-threads/wiki/ApiDocumentation ... but not identically. In particular I chose not to implement interrupt-thread or destroy-thread, but instead a thread-signalling approach. I'm still undecided about *default-special-bindings* (which I did not implement). I think it would be more emacs-like to capture the let bindings at make-thread time, but IIRC Stefan didn't like this idea the first time around. There are one or two semantics issues pointed out in the patch where I could use some advice. diff --git a/src/alloc.c b/src/alloc.c index dfae2d1..69742a3 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3102,6 +3102,9 @@ sweep_vectors (void) ptrdiff_t nbytes = PSEUDOVECTOR_NBYTES (vector); ptrdiff_t total_bytes = nbytes; + if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD)) + finalize_one_thread ((struct thread_state *) vector); + next = ADVANCE (vector, nbytes); /* While NEXT is not marked, try to coalesce with VECTOR, diff --git a/src/data.c b/src/data.c index d0ef573..fd2194f 100644 --- a/src/data.c +++ b/src/data.c @@ -94,6 +94,7 @@ static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; static Lisp_Object Qsubrp, Qmany, Qunevalled; Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; static Lisp_Object Qdefun; +Lisp_Object Qthread; Lisp_Object Qinteractive_form; @@ -211,6 +212,8 @@ for example, (type-of 1) returns `integer'. */) return Qfont_entity; if (FONT_OBJECT_P (object)) return Qfont_object; + if (THREADP (object)) + return Qthread; return Qvector; case Lisp_Float: @@ -458,6 +461,16 @@ DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, return Qnil; } +DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0, + doc: /* Return t if OBJECT is a thread. */) + (Lisp_Object object) +{ + if (THREADP (object)) + return Qt; + else + return Qnil; +} + /* Extract and set components of lists */ @@ -3091,6 +3104,7 @@ syms_of_data (void) DEFSYM (Qchar_table, "char-table"); DEFSYM (Qbool_vector, "bool-vector"); DEFSYM (Qhash_table, "hash-table"); + DEFSYM (Qthread, "thread"); /* Used by Fgarbage_collect. */ DEFSYM (Qinterval, "interval"); DEFSYM (Qmisc, "misc"); @@ -3133,6 +3147,7 @@ syms_of_data (void) defsubr (&Ssubrp); defsubr (&Sbyte_code_function_p); defsubr (&Schar_or_string_p); + defsubr (&Sthreadp); defsubr (&Scar); defsubr (&Scdr); defsubr (&Scar_safe); diff --git a/src/emacs.c b/src/emacs.c index ca9f201..9255252 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1552,6 +1552,8 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_ntterm (); #endif /* WINDOWSNT */ + syms_of_threads (); + keys_of_casefiddle (); keys_of_cmds (); keys_of_buffer (); diff --git a/src/lisp.h b/src/lisp.h index 2b3d40d..52a5232 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -554,6 +554,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) #define XBOOL_VECTOR(a) (eassert (BOOL_VECTOR_P (a)), \ ((struct Lisp_Bool_Vector *) \ XUNTAG (a, Lisp_Vectorlike))) +#define XTHREAD(a) (eassert (THREADP (a)), (struct thread_state *) XPNTR(a)) /* Construct a Lisp_Object from a value or address. */ @@ -1822,6 +1823,9 @@ typedef struct { #define CHECK_OVERLAY(x) \ CHECK_TYPE (OVERLAYP (x), Qoverlayp, x) +#define CHECK_THREAD(x) \ + CHECK_TYPE (THREADP (x), Qthreadp, x) + /* Since we can't assign directly to the CAR or CDR fields of a cons cell, use these when checking that those fields contain numbers. */ #define CHECK_NUMBER_CAR(x) \ @@ -2444,6 +2448,7 @@ extern Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp; extern Lisp_Object Qbuffer_or_string_p; extern Lisp_Object Qfboundp; extern Lisp_Object Qchar_table_p, Qvector_or_char_table_p; +extern Lisp_Object Qthreadp; extern Lisp_Object Qcdr; diff --git a/src/systhread.c b/src/systhread.c index b7147c4..968620b 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -105,19 +105,12 @@ lisp_mutex_lock (lisp_mutex_t *mutex) } self = current_thread; - while (mutex->owner != NULL /* && EQ (self->error_symbol, Qnil) */) + self->wait_condvar = &mutex->condition; + while (mutex->owner != NULL && EQ (self->error_symbol, Qnil)) pthread_cond_wait (&mutex->condition, &global_lock); + self->wait_condvar = NULL; -#if 0 - if (!EQ (self->error_symbol, Qnil)) - { - Lisp_Object error_symbol = self->error_symbol; - Lisp_Object data = self->error_data; - self->error_symbol = Qnil; - self->error_data = Qnil; - Fsignal (error_symbol, error_data); - } -#endif + post_acquire_global_lock (self); mutex->owner = self; mutex->count = 1; diff --git a/src/thread.c b/src/thread.c index 7d2f81e..5da2e10 100644 --- a/src/thread.c +++ b/src/thread.c @@ -20,15 +20,70 @@ along with GNU Emacs. If not, see . */ #include #include #include "lisp.h" +#include "character.h" +#include "buffer.h" -struct thread_state the_only_thread; +/* FIXME */ +extern void unbind_for_thread_switch (void); +extern void rebind_for_thread_switch (void); -struct thread_state *current_thread = &the_only_thread; +static struct thread_state primary_thread; -struct thread_state *all_threads = &the_only_thread; +struct thread_state *current_thread = &primary_thread; + +static struct thread_state *all_threads = &primary_thread; sys_mutex_t global_lock; +Lisp_Object Qthreadp; + + + +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. */ +void +post_acquire_global_lock (struct thread_state *self) +{ + Lisp_Object buffer; + + if (self != current_thread) + { + unbind_for_thread_switch (); + current_thread = self; + 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 (!EQ (current_thread->error_symbol, Qnil)) + { + 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 mark_one_thread (struct thread_state *thread) { @@ -113,19 +168,302 @@ unmark_threads (void) unmark_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; + + 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 = self->m_stack_bottom = &stack_pos; + self->thread_id = sys_thread_self (); + + acquire_global_lock (self); + + /* It might be nice to do something with errors here. */ + internal_condition_case (invoke_thread_function, Qt, do_nothing); + + unbind_for_thread_switch (); + + /* Unlink this thread from the list of all threads. */ + for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread) + ; + *iter = (*iter)->next_thread; + + self->m_last_thing_searched = Qnil; + self->m_saved_last_thing_searched = Qnil; + self->name = Qnil; + self->function = Qnil; + self->error_symbol = Qnil; + self->error_data = Qnil; + xfree (self->m_specpdl); + self->m_specpdl = NULL; + self->m_specpdl_ptr = NULL; + self->m_specpdl_size = 0; + + sys_cond_broadcast (&self->thread_condvar); + + release_global_lock (); + + return NULL; +} + void -init_threads_once (void) +finalize_one_thread (struct thread_state *state) { - the_only_thread.header.size + 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; + + /* Can't start a thread in temacs. */ + if (!initialized) + abort (); + + new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_gcprolist, + PVEC_THREAD); + memset ((char *) new_thread + offsetof (struct thread_state, m_gcprolist), + 0, sizeof (struct thread_state) - offsetof (struct thread_state, + m_gcprolist)); + + 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->m_specpdl_size = 50; + new_thread->m_specpdl = xmalloc (new_thread->m_specpdl_size + * sizeof (struct specbinding)); + 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 (! sys_thread_create (&thr, 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: /* FIXME */) + (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: /* FIXME */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + /* m_specpdl is set when the thread is created and cleared when the + thread dies. */ + return tstate->m_specpdl == NULL ? Qnil : Qt; +} + +static void +thread_join_callback (void *arg) +{ + struct thread_state *tstate = arg; + struct thread_state *self = current_thread; + + self->wait_condvar = &tstate->thread_condvar; + while (tstate->m_specpdl != NULL && EQ (self->error_symbol, Qnil)) + sys_cond_wait (self->wait_condvar, &global_lock); + + self->wait_condvar = NULL; + post_acquire_global_lock (self); +} + +DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0, + doc: /* FIXME */) + (Lisp_Object thread) +{ + struct thread_state *tstate; + + CHECK_THREAD (thread); + tstate = XTHREAD (thread); + + if (tstate->m_specpdl != NULL) + 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) + { + Lisp_Object thread; + + XSETTHREAD (thread, iter); + result = Fcons (thread, result); + } + + return result; +} + + + +static void +init_primary_thread (void) +{ + primary_thread.header.size = PSEUDOVECSIZE (struct thread_state, m_gcprolist); - XSETPVECTYPE (&the_only_thread, PVEC_THREAD); - the_only_thread.m_last_thing_searched = Qnil; - the_only_thread.m_saved_last_thing_searched = Qnil; + 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; + + sys_cond_init (&primary_thread.thread_condvar); +} + +void +init_threads_once (void) +{ + init_primary_thread (); } void init_threads (void) { + init_primary_thread (); + sys_mutex_init (&global_lock); sys_mutex_lock (&global_lock); } + +void +syms_of_threads (void) +{ + defsubr (&Sthread_yield); + defsubr (&Smake_thread); + defsubr (&Scurrent_thread); + defsubr (&Sthread_name); + defsubr (&Sthread_signal); + defsubr (&Sthread_alive_p); + defsubr (&Sthread_join); + defsubr (&Sall_threads); + + Qthreadp = intern_c_string ("threadp"); + staticpro (&Qthreadp); +} diff --git a/src/thread.h b/src/thread.h index df26b88..3b53331 100644 --- a/src/thread.h +++ b/src/thread.h @@ -34,6 +34,16 @@ struct thread_state 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; + /* m_gcprolist must be the first non-lisp field. */ /* Recording what needs to be marked for gc. */ struct gcpro *m_gcprolist; @@ -142,6 +152,18 @@ struct thread_state /*re_char*/ unsigned char *m_whitespace_regexp; #define whitespace_regexp (current_thread->m_whitespace_regexp) + /* 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; }; @@ -149,10 +171,13 @@ struct thread_state extern struct thread_state *current_thread; extern sys_mutex_t global_lock; +extern void post_acquire_global_lock (struct thread_state *); extern void unmark_threads (void); +extern void finalize_one_thread (struct thread_state *state); extern void init_threads_once (void); extern void init_threads (void); +extern void syms_of_threads (void); #endif /* THREAD_H */ commit 60a9d2a7728895c1a5bfbc37c3bfa8fde35abe61 Author: Tom Tromey Date: Wed Aug 15 13:07:04 2012 -0600 This turns thread_state into a pseudovector and updates various bits of Emacs to cope. diff --git a/src/emacs.c b/src/emacs.c index 443fe59..ca9f201 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1226,6 +1226,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem if (!initialized) { init_alloc_once (); + init_threads_once (); init_obarray (); init_eval_once (); init_charset_once (); diff --git a/src/lisp.h b/src/lisp.h index cbb5b51..2b3d40d 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -365,6 +365,7 @@ enum pvec_type PVEC_WINDOW_CONFIGURATION, PVEC_SUBR, PVEC_OTHER, + PVEC_THREAD, /* These last 4 are special because we OR them in fns.c:internal_equal, so they have to use a disjoint bit pattern: if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE @@ -603,6 +604,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) #define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) #define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE)) +#define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD)) /* Convenience macros for dealing with Lisp arrays. */ @@ -1701,6 +1703,7 @@ typedef struct { #define SUB_CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_SUB_CHAR_TABLE) #define BOOL_VECTOR_P(x) PSEUDOVECTORP (x, PVEC_BOOL_VECTOR) #define FRAMEP(x) PSEUDOVECTORP (x, PVEC_FRAME) +#define THREADP(x) PSEUDOVECTORP (x, PVEC_THREAD) /* Test for image (image . spec) */ #define IMAGEP(x) (CONSP (x) && EQ (XCAR (x), Qimage)) diff --git a/src/print.c b/src/print.c index 23ad6c0..4537521 100644 --- a/src/print.c +++ b/src/print.c @@ -1943,6 +1943,18 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag } PRINTCHAR ('>'); } + else if (THREADP (obj)) + { + strout ("#name)) + print_string (XTHREAD (obj)->name, printcharfun); + else + { + int len = sprintf (buf, "%p", XTHREAD (obj)); + strout (buf, len, len, printcharfun); + } + PRINTCHAR ('>'); + } else { ptrdiff_t size = ASIZE (obj); diff --git a/src/thread.c b/src/thread.c index 605a52c..7d2f81e 100644 --- a/src/thread.c +++ b/src/thread.c @@ -32,7 +32,7 @@ sys_mutex_t global_lock; static void mark_one_thread (struct thread_state *thread) { - register struct specbinding *bind; + struct specbinding *bind; struct handler *handler; Lisp_Object tem; @@ -48,7 +48,7 @@ mark_one_thread (struct thread_state *thread) mark_stack (thread->m_stack_bottom, thread->stack_top); #else { - register struct gcpro *tail; + struct gcpro *tail; for (tail = thread->m_gcprolist; tail; tail = tail->next) for (i = 0; i < tail->nvars; i++) mark_object (tail->var[i]); @@ -88,7 +88,13 @@ mark_threads_callback (void *ignore) struct thread_state *iter; for (iter = all_threads; iter; iter = iter->next_thread) - mark_one_thread (iter); + { + Lisp_Object thread_obj; + + XSETTHREAD (thread_obj, iter); + mark_object (thread_obj); + mark_one_thread (iter); + } } void @@ -108,6 +114,16 @@ unmark_threads (void) } void +init_threads_once (void) +{ + the_only_thread.header.size + = PSEUDOVECSIZE (struct thread_state, m_gcprolist); + XSETPVECTYPE (&the_only_thread, PVEC_THREAD); + the_only_thread.m_last_thing_searched = Qnil; + the_only_thread.m_saved_last_thing_searched = Qnil; +} + +void init_threads (void) { sys_mutex_init (&global_lock); diff --git a/src/thread.h b/src/thread.h index def05fd..df26b88 100644 --- a/src/thread.h +++ b/src/thread.h @@ -23,6 +23,8 @@ along with GNU Emacs. If not, see . */ 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. */ @@ -150,6 +152,7 @@ extern sys_mutex_t global_lock; extern void unmark_threads (void); +extern void init_threads_once (void); extern void init_threads (void); #endif /* THREAD_H */ commit e160922c665ba65e1dba5b87a924927e61be43b9 Author: Tom Tromey Date: Wed Aug 15 13:04:34 2012 -0600 This introduces some new functions to handle the specpdl. The basic idea is that when a thread loses the interpreter lock, it will unbind the bindings it has put in place. Then when a thread acquires the lock, it will restore its bindings. This code reuses an existing empty slot in struct specbinding to store the current value when the thread is "swapped out". This approach performs worse than my previously planned approach. However, it was one I could implement with minimal time and brainpower. I hope that perhaps someone else could improve the code once it is in. diff --git a/src/eval.c b/src/eval.c index 49ead49..f5f6fe7 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3102,6 +3102,52 @@ grow_specpdl (void) specpdl_ptr = specpdl + count; } +static Lisp_Object +binding_symbol (const struct specbinding *bind) +{ + if (!CONSP (bind->symbol)) + return bind->symbol; + return XCAR (bind->symbol); +} + +void +do_specbind (struct Lisp_Symbol *sym, struct specbinding *bind, + Lisp_Object value) +{ + switch (sym->redirect) + { + case SYMBOL_PLAINVAL: + if (!sym->constant) + SET_SYMBOL_VAL (sym, value); + else + set_internal (bind->symbol, value, Qnil, 1); + break; + + case SYMBOL_LOCALIZED: + case SYMBOL_FORWARDED: + if ((sym->redirect == SYMBOL_LOCALIZED + || BUFFER_OBJFWDP (SYMBOL_FWD (sym))) + && CONSP (bind->symbol)) + { + Lisp_Object where; + + where = XCAR (XCDR (bind->symbol)); + if (NILP (where) + && sym->redirect == SYMBOL_FORWARDED) + { + Fset_default (XCAR (bind->symbol), value); + return; + } + } + + set_internal (binding_symbol (bind), value, Qnil, 1); + break; + + default: + abort (); + } +} + /* `specpdl_ptr->symbol' is a field which describes which variable is let-bound, so it can be properly undone when we unbind_to. It can have the following two shapes: @@ -3140,11 +3186,9 @@ specbind (Lisp_Object symbol, Lisp_Object value) specpdl_ptr->symbol = symbol; specpdl_ptr->old_value = SYMBOL_VAL (sym); specpdl_ptr->func = NULL; + specpdl_ptr->saved_value = Qnil; ++specpdl_ptr; - if (!sym->constant) - SET_SYMBOL_VAL (sym, value); - else - set_internal (symbol, value, Qnil, 1); + do_specbind (sym, specpdl_ptr - 1, value); break; case SYMBOL_LOCALIZED: if (SYMBOL_BLV (sym)->frame_local) @@ -3199,7 +3243,7 @@ specbind (Lisp_Object symbol, Lisp_Object value) { eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym))); ++specpdl_ptr; - Fset_default (symbol, value); + do_specbind (sym, specpdl_ptr - 1, value); return; } } @@ -3207,7 +3251,7 @@ specbind (Lisp_Object symbol, Lisp_Object value) specpdl_ptr->symbol = symbol; specpdl_ptr++; - set_internal (symbol, value, Qnil, 1); + do_specbind (sym, specpdl_ptr - 1, value); break; } default: abort (); @@ -3224,9 +3268,67 @@ record_unwind_protect (Lisp_Object (*function) (Lisp_Object), Lisp_Object arg) specpdl_ptr->func = function; specpdl_ptr->symbol = Qnil; specpdl_ptr->old_value = arg; + specpdl_ptr->saved_value = Qnil; specpdl_ptr++; } +void +rebind_for_thread_switch (void) +{ + struct specbinding *bind; + + for (bind = specpdl; bind != specpdl_ptr; ++bind) + { + if (bind->func == NULL) + { + Lisp_Object value = bind->saved_value; + + bind->saved_value = Qnil; + do_specbind (XSYMBOL (binding_symbol (bind)), bind, value); + } + } +} + +static void +do_one_unbind (const struct specbinding *this_binding, int unwinding) +{ + if (this_binding->func != 0) + (*this_binding->func) (this_binding->old_value); + /* If the symbol is a list, it is really (SYMBOL WHERE + . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a + frame. If WHERE is a buffer or frame, this indicates we + bound a variable that had a buffer-local or frame-local + binding. WHERE nil means that the variable had the default + value when it was bound. CURRENT-BUFFER is the buffer that + was current when the variable was bound. */ + else if (CONSP (this_binding->symbol)) + { + Lisp_Object symbol, where; + + symbol = XCAR (this_binding->symbol); + where = XCAR (XCDR (this_binding->symbol)); + + if (NILP (where)) + Fset_default (symbol, this_binding->old_value); + /* If `where' is non-nil, reset the value in the appropriate + local binding, but only if that binding still exists. */ + else if (BUFFERP (where) + ? !NILP (Flocal_variable_p (symbol, where)) + : !NILP (Fassq (symbol, XFRAME (where)->param_alist))) + set_internal (symbol, this_binding->old_value, where, 1); + } + /* 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. */ + else if (XSYMBOL (this_binding->symbol)->redirect == SYMBOL_PLAINVAL) + SET_SYMBOL_VAL (XSYMBOL (this_binding->symbol), + this_binding->old_value); + else + /* NOTE: we only ever come here if make_local_foo was used for + the first time on this var within this let. */ + Fset_default (this_binding->symbol, this_binding->old_value); +} + Lisp_Object unbind_to (ptrdiff_t count, Lisp_Object value) { @@ -3247,41 +3349,7 @@ unbind_to (ptrdiff_t count, Lisp_Object value) struct specbinding this_binding; this_binding = *--specpdl_ptr; - if (this_binding.func != 0) - (*this_binding.func) (this_binding.old_value); - /* If the symbol is a list, it is really (SYMBOL WHERE - . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a - frame. If WHERE is a buffer or frame, this indicates we - bound a variable that had a buffer-local or frame-local - binding. WHERE nil means that the variable had the default - value when it was bound. CURRENT-BUFFER is the buffer that - was current when the variable was bound. */ - else if (CONSP (this_binding.symbol)) - { - Lisp_Object symbol, where; - - symbol = XCAR (this_binding.symbol); - where = XCAR (XCDR (this_binding.symbol)); - - if (NILP (where)) - Fset_default (symbol, this_binding.old_value); - /* If `where' is non-nil, reset the value in the appropriate - local binding, but only if that binding still exists. */ - else if (BUFFERP (where) - ? !NILP (Flocal_variable_p (symbol, where)) - : !NILP (Fassq (symbol, XFRAME (where)->param_alist))) - set_internal (symbol, this_binding.old_value, where, 1); - } - /* 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. */ - else if (XSYMBOL (this_binding.symbol)->redirect == SYMBOL_PLAINVAL) - SET_SYMBOL_VAL (XSYMBOL (this_binding.symbol), - this_binding.old_value); - else - /* NOTE: we only ever come here if make_local_foo was used for - the first time on this var within this let. */ - Fset_default (this_binding.symbol, this_binding.old_value); + do_one_unbind (&this_binding, 1); } if (NILP (Vquit_flag) && !NILP (quitf)) @@ -3291,6 +3359,21 @@ unbind_to (ptrdiff_t count, Lisp_Object value) return value; } +void +unbind_for_thread_switch (void) +{ + struct specbinding *bind; + + for (bind = specpdl_ptr; bind != specpdl; --bind) + { + if (bind->func == NULL) + { + bind->saved_value = find_symbol_value (binding_symbol (bind)); + do_one_unbind (bind, 0); + } + } +} + DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0, doc: /* Return non-nil if SYMBOL's global binding has been declared special. A special variable is one that will be bound dynamically, even in a diff --git a/src/lisp.h b/src/lisp.h index b0ed9be..cbb5b51 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2014,7 +2014,9 @@ struct specbinding { Lisp_Object symbol, old_value; specbinding_func func; - Lisp_Object unused; /* Dividing by 16 is faster than by 12 */ + /* Normally this is unused; but it is to the symbol's current + value when a thread is swapped out. */ + Lisp_Object saved_value; }; #define SPECPDL_INDEX() (specpdl_ptr - specpdl) diff --git a/src/thread.c b/src/thread.c index 19faa1b..605a52c 100644 --- a/src/thread.c +++ b/src/thread.c @@ -40,6 +40,7 @@ mark_one_thread (struct thread_state *thread) { mark_object (bind->symbol); mark_object (bind->old_value); + mark_object (bind->saved_value); } #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ diff --git a/src/thread.h b/src/thread.h index 020346b..def05fd 100644 --- a/src/thread.h +++ b/src/thread.h @@ -83,6 +83,12 @@ struct thread_state struct specbinding *m_specpdl_ptr; #define specpdl_ptr (current_thread->m_specpdl_ptr) + /* Pointer to the first "saved" element in specpdl. When this + thread is swapped out, the current values of all specpdl bindings + are pushed onto the specpdl; then these are popped again when + switching back to this thread. */ + struct specbinding *m_saved_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) commit 14b3dc5e4f2cdefde1ba04ddd3525115e7ca7dce Author: Tom Tromey Date: Wed Aug 15 13:03:17 2012 -0600 This introduces the low-level system threading support. It also adds the global lock. The low-level support is a bit over-eager, in that even at the end of the present series, it will not all be used. I think thiat is ok since I plan to use it all eventually -- in particular for the emacs lisp mutex implementation. I've only implemented the pthreads-based version. I think it should be relatively clear how to port this to other systems, though. I'd also like to do a "no threads" port that will turn most things into no-ops, and have thread-creation fail. I was thinking perhaps I'd make a future (provide 'threads) conditional on threads actually working. One other minor enhancement available here is to make it possible to set the name of the new thread at the OS layer. That way gdb, e.g., could display thread names. diff --git a/src/Makefile.in b/src/Makefile.in index 2d1bdd0..01034ca 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -336,7 +336,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ eval.o floatfns.o fns.o font.o print.o lread.o \ syntax.o $(UNEXEC_OBJ) bytecode.o \ process.o gnutls.o callproc.o \ - region-cache.o sound.o atimer.o thread.o \ + region-cache.o sound.o atimer.o thread.o systhread.o \ doprnt.o intervals.o textprop.o composite.o xml.o \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) obj = $(base_obj) $(NS_OBJC_OBJ) diff --git a/src/emacs.c b/src/emacs.c index e1acd36..443fe59 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1270,6 +1270,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem } init_alloc (); + init_threads (); if (do_initial_setlocale) { diff --git a/src/lisp.h b/src/lisp.h index a666532..b0ed9be 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -29,6 +29,8 @@ along with GNU Emacs. If not, see . */ #include +#include "systhread.h" + INLINE_HEADER_BEGIN #ifndef LISP_INLINE # define LISP_INLINE INLINE diff --git a/src/systhread.c b/src/systhread.c new file mode 100644 index 0000000..b7147c4 --- /dev/null +++ b/src/systhread.c @@ -0,0 +1,189 @@ +/* System thread definitions + Copyright (C) 2012 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" + +#ifdef HAVE_PTHREAD + +#include + +void +sys_mutex_init (sys_mutex_t *mutex) +{ + pthread_mutex_init (mutex, NULL); +} + +void +sys_mutex_lock (sys_mutex_t *mutex) +{ + pthread_mutex_lock (mutex); +} + +void +sys_mutex_unlock (sys_mutex_t *mutex) +{ + pthread_mutex_unlock (mutex); +} + +void +sys_mutex_destroy (sys_mutex_t *mutex) +{ + pthread_mutex_destroy (mutex); +} + +void +sys_cond_init (sys_cond_t *cond) +{ + pthread_cond_init (cond, NULL); +} + +void +sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex) +{ + pthread_cond_wait (cond, mutex); +} + +void +sys_cond_signal (sys_cond_t *cond) +{ + pthread_cond_signal (cond); +} + +void +sys_cond_broadcast (sys_cond_t *cond) +{ + pthread_cond_broadcast (cond); +} + +void +sys_cond_destroy (sys_cond_t *cond) +{ + pthread_cond_destroy (cond); +} + +void +lisp_mutex_init (lisp_mutex_t *mutex) +{ + mutex->owner = NULL; + mutex->count = 0; + /* A lisp "mutex" is really a condition variable. */ + pthread_cond_init (&mutex->condition, NULL); +} + +void +lisp_mutex_lock (lisp_mutex_t *mutex) +{ + struct thread_state *self; + + if (mutex->owner == NULL) + { + mutex->owner = current_thread; + mutex->count = 1; + return; + } + if (mutex->owner == current_thread) + { + ++mutex->count; + return; + } + + self = current_thread; + while (mutex->owner != NULL /* && EQ (self->error_symbol, Qnil) */) + pthread_cond_wait (&mutex->condition, &global_lock); + +#if 0 + if (!EQ (self->error_symbol, Qnil)) + { + Lisp_Object error_symbol = self->error_symbol; + Lisp_Object data = self->error_data; + self->error_symbol = Qnil; + self->error_data = Qnil; + Fsignal (error_symbol, error_data); + } +#endif + + mutex->owner = self; + mutex->count = 1; +} + +void +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; + + mutex->owner = NULL; + pthread_cond_broadcast (&mutex->condition); + + post_acquire_global_lock (self); +} + +void +lisp_mutex_destroy (lisp_mutex_t *mutex) +{ + sys_cond_destroy (&mutex->condition); +} + +sys_thread_t +sys_thread_self (void) +{ + return pthread_self (); +} + +int +sys_thread_equal (sys_thread_t one, sys_thread_t two) +{ + return pthread_equal (one, two); +} + +int +sys_thread_create (sys_thread_t *thread_ptr, thread_creation_function *func, + void *arg) +{ + pthread_attr_t attr; + int result = 0; + + if (pthread_attr_init (&attr)) + return 0; + + if (!pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED)) + result = pthread_create (thread_ptr, &attr, func, arg) == 0; + + pthread_attr_destroy (&attr); + + return result; +} + +void +sys_thread_yield (void) +{ + sched_yield (); +} + +#else + +#error port me + +#endif diff --git a/src/systhread.h b/src/systhread.h new file mode 100644 index 0000000..bf9358c --- /dev/null +++ b/src/systhread.h @@ -0,0 +1,80 @@ +/* System thread definitions + Copyright (C) 2012 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 SYSTHREAD_H +#define SYSTHREAD_H + +#ifdef HAVE_PTHREAD + +#include + +/* A mutex in lisp is represented by a pthread condition variable. + The pthread mutex associated with this condition variable is the + global lock. + + Using a condition variable lets us implement interruptibility for + lisp mutexes. */ +typedef struct +{ + struct thread_state *owner; + unsigned int count; + pthread_cond_t condition; +} lisp_mutex_t; + +/* A system mutex is just a pthread mutex. This is only used for the + GIL. */ +typedef pthread_mutex_t sys_mutex_t; + +typedef pthread_cond_t sys_cond_t; + +/* A system thread. */ +typedef pthread_t sys_thread_t; + +#else + +#error port me + +#endif + +typedef void *(thread_creation_function) (void *); + +extern void sys_mutex_init (sys_mutex_t *); +extern void sys_mutex_lock (sys_mutex_t *); +extern void sys_mutex_unlock (sys_mutex_t *); +extern void sys_mutex_destroy (sys_mutex_t *); + +extern void sys_cond_init (sys_cond_t *); +extern void sys_cond_wait (sys_cond_t *, sys_mutex_t *); +extern void sys_cond_signal (sys_cond_t *); +extern void sys_cond_broadcast (sys_cond_t *); +extern void sys_cond_destroy (sys_cond_t *); + +extern void lisp_mutex_init (lisp_mutex_t *); +extern void lisp_mutex_lock (lisp_mutex_t *); +extern void lisp_mutex_unlock (lisp_mutex_t *); +extern void lisp_mutex_destroy (lisp_mutex_t *); + +extern sys_thread_t sys_thread_self (void); +extern int sys_thread_equal (sys_thread_t, sys_thread_t); + +extern int sys_thread_create (sys_thread_t *, thread_creation_function *, + void *); + +extern void sys_thread_yield (void); + +#endif /* SYSTHREAD_H */ diff --git a/src/thread.c b/src/thread.c index ba2d663..19faa1b 100644 --- a/src/thread.c +++ b/src/thread.c @@ -27,6 +27,8 @@ struct thread_state *current_thread = &the_only_thread; struct thread_state *all_threads = &the_only_thread; +sys_mutex_t global_lock; + static void mark_one_thread (struct thread_state *thread) { @@ -103,3 +105,10 @@ unmark_threads (void) if (iter->m_byte_stack_list) unmark_byte_stack (iter->m_byte_stack_list); } + +void +init_threads (void) +{ + sys_mutex_init (&global_lock); + sys_mutex_lock (&global_lock); +} diff --git a/src/thread.h b/src/thread.h index 6d61d0e..020346b 100644 --- a/src/thread.h +++ b/src/thread.h @@ -140,6 +140,10 @@ struct thread_state extern struct thread_state *current_thread; +extern sys_mutex_t global_lock; + extern void unmark_threads (void); +extern void init_threads (void); + #endif /* THREAD_H */ commit 2d525b793f1b0fd2b6f66881310bec8684bceffe Author: Tom Tromey Date: Wed Aug 15 13:01:36 2012 -0600 This parameterizes the GC a bit to make it thread-ready. The basic idea is that whenever a thread "exits lisp" -- that is, releases the global lock in favor of another thread -- it must save its stack boundaries in the thread object. This way the boundaries are always available for marking. This is the purpose of flush_stack_call_func. I haven't tested this under all the possible GC configurations. There is a new FIXME in a spot that i didn't convert. Arguably all_threads should go in the previous patch. diff --git a/src/alloc.c b/src/alloc.c index bdf7b24..dfae2d1 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -387,7 +387,6 @@ static struct mem_node mem_z; static struct Lisp_Vector *allocate_vectorlike (ptrdiff_t); static void lisp_free (void *); -static void mark_stack (void); static int live_vector_p (struct mem_node *, void *); static int live_buffer_p (struct mem_node *, void *); static int live_string_p (struct mem_node *, void *); @@ -4865,8 +4864,27 @@ dump_zombies (void) would be necessary, each one starting with one byte more offset from the stack start. */ -static void -mark_stack (void) +void +mark_stack (char *bottom, char *end) +{ + /* This assumes that the stack is a contiguous region in memory. If + that's not the case, something has to be done here to iterate + over the stack segments. */ + mark_memory (bottom, end); + + /* Allow for marking a secondary stack, like the register stack on the + ia64. */ +#ifdef GC_MARK_SECONDARY_STACK + GC_MARK_SECONDARY_STACK (); +#endif + +#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS + check_gcpros (); +#endif +} + +void +flush_stack_call_func (void (*func) (void *arg), void *arg) { void *end; @@ -4922,20 +4940,8 @@ mark_stack (void) #endif /* not GC_SAVE_REGISTERS_ON_STACK */ #endif /* not HAVE___BUILTIN_UNWIND_INIT */ - /* This assumes that the stack is a contiguous region in memory. If - that's not the case, something has to be done here to iterate - over the stack segments. */ - mark_memory (stack_bottom, end); - - /* Allow for marking a secondary stack, like the register stack on the - ia64. */ -#ifdef GC_MARK_SECONDARY_STACK - GC_MARK_SECONDARY_STACK (); -#endif - -#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS - check_gcpros (); -#endif + current_thread->stack_top = end; + (*func) (arg); } #endif /* GC_MARK_STACK != 0 */ @@ -5457,11 +5463,7 @@ See Info node `(elisp)Garbage Collection'. */) for (i = 0; i < staticidx; i++) mark_object (*staticvec[i]); - for (bind = specpdl; bind != specpdl_ptr; bind++) - { - mark_object (bind->symbol); - mark_object (bind->old_value); - } + mark_threads (); mark_terminals (); mark_kboards (); mark_ttys (); @@ -5473,40 +5475,12 @@ See Info node `(elisp)Garbage Collection'. */) } #endif -#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ - || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) - mark_stack (); -#else - { - register struct gcpro *tail; - for (tail = gcprolist; tail; tail = tail->next) - for (i = 0; i < tail->nvars; i++) - mark_object (tail->var[i]); - } - mark_byte_stack (); - { - struct catchtag *catch; - struct handler *handler; - - for (catch = catchlist; catch; catch = catch->next) - { - mark_object (catch->tag); - mark_object (catch->val); - } - for (handler = handlerlist; handler; handler = handler->next) - { - mark_object (handler->handler); - mark_object (handler->var); - } - } - mark_backtrace (); -#endif - #ifdef HAVE_WINDOW_SYSTEM mark_fringe_data (); #endif #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES + FIXME; mark_stack (); #endif @@ -5556,7 +5530,7 @@ See Info node `(elisp)Garbage Collection'. */) /* Clear the mark bits that we set in certain root slots. */ - unmark_byte_stack (); + unmark_threads (); VECTOR_UNMARK (&buffer_defaults); VECTOR_UNMARK (&buffer_local_symbols); diff --git a/src/bytecode.c b/src/bytecode.c index 0194594..d61e37d 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -335,12 +335,11 @@ struct byte_stack #if BYTE_MARK_STACK void -mark_byte_stack (void) +mark_byte_stack (struct byte_stack *stack) { - struct byte_stack *stack; Lisp_Object *obj; - for (stack = byte_stack_list; stack; stack = stack->next) + for (; stack; stack = stack->next) { /* If STACK->top is null here, this means there's an opcode in Fbyte_code that wasn't expected to GC, but did. To find out @@ -364,11 +363,9 @@ mark_byte_stack (void) counters. Called when GC has completed. */ void -unmark_byte_stack (void) +unmark_byte_stack (struct byte_stack *stack) { - struct byte_stack *stack; - - for (stack = byte_stack_list; stack; stack = stack->next) + for (; stack; stack = stack->next) { if (stack->byte_string_start != SDATA (stack->byte_string)) { diff --git a/src/eval.c b/src/eval.c index 768cdc1..49ead49 100644 --- a/src/eval.c +++ b/src/eval.c @@ -165,6 +165,19 @@ init_eval (void) when_entered_debugger = -1; } +#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ + || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) +void +mark_catchlist (struct catchtag *catch) +{ + for (; catch; catch = catch->next) + { + mark_object (catch->tag); + mark_object (catch->val); + } +} +#endif + /* Unwind-protect function used by call_debugger. */ static Lisp_Object diff --git a/src/lisp.h b/src/lisp.h index 0367d99..a666532 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2715,6 +2715,10 @@ extern void mark_object (Lisp_Object); #if defined REL_ALLOC && !defined SYSTEM_MALLOC extern void refill_memory_reserve (void); #endif +#if GC_MARK_STACK +extern void mark_stack (char *, char *); +#endif +extern void flush_stack_call_func (void (*func) (void *arg), void *arg); extern const char *pending_malloc_warning; extern Lisp_Object zero_vector; extern EMACS_INT consing_since_gc; @@ -2902,6 +2906,10 @@ extern Lisp_Object Vautoload_queue; extern Lisp_Object Vsignaling_function; extern Lisp_Object inhibit_lisp_code; extern int handling_signal; +#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ + || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) +extern void mark_catchlist (struct catchtag *); +#endif /* To run a normal hook, use the appropriate function from the list below. The calling convention: @@ -2951,11 +2959,11 @@ extern Lisp_Object safe_call (ptrdiff_t, Lisp_Object, ...); extern Lisp_Object safe_call1 (Lisp_Object, Lisp_Object); extern Lisp_Object safe_call2 (Lisp_Object, Lisp_Object, Lisp_Object); extern void init_eval (void); -#if BYTE_MARK_STACK -extern void mark_backtrace (void); -#endif extern void syms_of_eval (void); +/* Defined in thread.c. */ +extern void mark_threads (void); + /* Defined in editfns.c. */ extern Lisp_Object Qfield; extern void insert1 (Lisp_Object); @@ -3211,9 +3219,9 @@ extern int read_bytecode_char (int); extern Lisp_Object Qbytecode; extern void syms_of_bytecode (void); #if BYTE_MARK_STACK -extern void mark_byte_stack (void); +extern void mark_byte_stack (struct byte_stack *); #endif -extern void unmark_byte_stack (void); +extern void unmark_byte_stack (struct byte_stack *); extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, ptrdiff_t, Lisp_Object *); diff --git a/src/thread.c b/src/thread.c index 0bd97b4..ba2d663 100644 --- a/src/thread.c +++ b/src/thread.c @@ -24,3 +24,82 @@ along with GNU Emacs. If not, see . */ struct thread_state the_only_thread; struct thread_state *current_thread = &the_only_thread; + +struct thread_state *all_threads = &the_only_thread; + +static void +mark_one_thread (struct thread_state *thread) +{ + register struct specbinding *bind; + struct handler *handler; + Lisp_Object tem; + + for (bind = thread->m_specpdl; bind != thread->m_specpdl_ptr; bind++) + { + mark_object (bind->symbol); + mark_object (bind->old_value); + } + +#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ + || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS) + mark_stack (thread->m_stack_bottom, thread->stack_top); +#else + { + register struct gcpro *tail; + for (tail = thread->m_gcprolist; tail; tail = tail->next) + for (i = 0; i < tail->nvars; i++) + mark_object (tail->var[i]); + } + +#if BYTE_MARK_STACK + if (thread->m_byte_stack_list) + mark_byte_stack (thread->m_byte_stack_list); +#endif + + mark_catchlist (thread->m_catchlist); + + for (handler = thread->m_handlerlist; handler; handler = handler->next) + { + mark_object (handler->handler); + mark_object (handler->var); + } + + mark_backtrace (thread->m_backtrace_list); +#endif + + 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) + 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) + unmark_byte_stack (iter->m_byte_stack_list); +} diff --git a/src/thread.h b/src/thread.h index b2eb04d..6d61d0e 100644 --- a/src/thread.h +++ b/src/thread.h @@ -133,8 +133,13 @@ struct thread_state /* Regexp to use to replace spaces, or NULL meaning don't. */ /*re_char*/ unsigned char *m_whitespace_regexp; #define whitespace_regexp (current_thread->m_whitespace_regexp) + + /* Threads are kept on a linked list. */ + struct thread_state *next_thread; }; extern struct thread_state *current_thread; +extern void unmark_threads (void); + #endif /* THREAD_H */ commit 68b32482437e05f0994c4dd0ab5b0c27d39f0f6d Author: Tom Tromey Date: Wed Aug 15 12:56:38 2012 -0600 This introduces a thread-state object and moves various C globals there. It also introduces #defines for these globals to avoid a monster patch. The #defines mean that this patch also has to rename a few fields whose names clash with the defines. There is currently just a single "thread"; so this patch does not impact Emacs behavior in any significant way. diff --git a/src/Makefile.in b/src/Makefile.in index 4b1520a..2d1bdd0 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -336,7 +336,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ eval.o floatfns.o fns.o font.o print.o lread.o \ syntax.o $(UNEXEC_OBJ) bytecode.o \ process.o gnutls.o callproc.o \ - region-cache.o sound.o atimer.o \ + region-cache.o sound.o atimer.o thread.o \ doprnt.o intervals.o textprop.o composite.o xml.o \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) obj = $(base_obj) $(NS_OBJC_OBJ) diff --git a/src/alloc.c b/src/alloc.c index 1d484d4..bdf7b24 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -372,10 +372,6 @@ struct mem_node enum mem_type type; }; -/* Base address of stack. Set in main. */ - -Lisp_Object *stack_base; - /* Root of the tree describing allocated Lisp memory. */ static struct mem_node *mem_root; @@ -423,10 +419,6 @@ static void check_gcpros (void); # define DEADP(x) 0 #endif -/* Recording what needs to be marked for gc. */ - -struct gcpro *gcprolist; - /* Addresses of staticpro'd variables. Initialize it to a nonzero value; otherwise some compilers put it into BSS. */ @@ -4891,7 +4883,7 @@ mark_stack (void) Lisp_Object o; jmp_buf j; } j; - volatile int stack_grows_down_p = (char *) &j > (char *) stack_base; + volatile int stack_grows_down_p = (char *) &j > (char *) stack_bottom; #endif /* This trick flushes the register windows so that all the state of the process is contained in the stack. */ @@ -4933,7 +4925,7 @@ mark_stack (void) /* This assumes that the stack is a contiguous region in memory. If that's not the case, something has to be done here to iterate over the stack segments. */ - mark_memory (stack_base, end); + mark_memory (stack_bottom, end); /* Allow for marking a secondary stack, like the register stack on the ia64. */ diff --git a/src/buffer.c b/src/buffer.c index 56d6231..7fb1029 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -44,8 +44,6 @@ along with GNU Emacs. If not, see . */ #include "keymap.h" #include "frame.h" -struct buffer *current_buffer; /* the current buffer */ - /* First buffer in chain of all buffers (in reverse order of creation). Threaded through ->header.next.buffer. */ diff --git a/src/buffer.h b/src/buffer.h index 7a6bdde..1c9f5d9 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -872,10 +872,6 @@ extern struct buffer *all_buffers; #define FOR_EACH_BUFFER(b) \ for ((b) = all_buffers; (b); (b) = (b)->header.next.buffer) -/* This points to the current buffer. */ - -extern struct buffer *current_buffer; - /* This structure holds the default values of the buffer-local variables that have special slots in each buffer. The default value occupies the same slot in this structure diff --git a/src/bytecode.c b/src/bytecode.c index 5ac8b4f..0194594 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -328,7 +328,7 @@ struct byte_stack done. Signaling an error truncates the list analogous to gcprolist. */ -struct byte_stack *byte_stack_list; +/* struct byte_stack *byte_stack_list; */ /* Mark objects on byte_stack_list. Called during GC. */ diff --git a/src/emacs.c b/src/emacs.c index 8d458c6..e1acd36 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -140,10 +140,6 @@ int running_asynch_code; int 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; @@ -687,9 +683,6 @@ void (*__malloc_initialize_hook) (void) EXTERNALLY_VISIBLE = malloc_initialize_h int main (int argc, char **argv) { -#if GC_MARK_STACK - Lisp_Object dummy; -#endif char stack_bottom_variable; int do_initial_setlocale; int skip_args = 0; @@ -704,9 +697,8 @@ main (int argc, char **argv) #endif char *ch_to_dir; -#if GC_MARK_STACK - stack_base = &dummy; -#endif + /* Record (approximately) where the stack begins. */ + stack_bottom = &stack_bottom_variable; #if defined (USE_GTK) && defined (G_SLICE_ALWAYS_MALLOC) /* This is used by the Cygwin build. */ @@ -852,9 +844,6 @@ main (int argc, char **argv) } #endif /* HAVE_SETRLIMIT and RLIMIT_STACK */ - /* Record (approximately) where the stack begins. */ - stack_bottom = &stack_bottom_variable; - clearerr (stdin); #ifndef SYSTEM_MALLOC diff --git a/src/eval.c b/src/eval.c index b531f79..768cdc1 100644 --- a/src/eval.c +++ b/src/eval.c @@ -42,12 +42,12 @@ struct backtrace unsigned int debug_on_exit : 1; }; -static struct backtrace *backtrace_list; +/* static struct backtrace *backtrace_list; */ -#if !BYTE_MARK_STACK -static -#endif -struct catchtag *catchlist; +/* #if !BYTE_MARK_STACK */ +/* static */ +/* #endif */ +/* struct catchtag *catchlist; */ /* Chain of condition handlers currently in effect. The elements of this chain are contained in the stack frames @@ -55,10 +55,10 @@ struct catchtag *catchlist; When an error is signaled (by calling Fsignal, below), this chain is searched for an element that applies. */ -#if !BYTE_MARK_STACK -static -#endif -struct handler *handlerlist; +/* #if !BYTE_MARK_STACK */ +/* static */ +/* #endif */ +/* struct handler *handlerlist; */ #ifdef DEBUG_GCPRO /* Count levels of GCPRO to detect failure to UNGCPRO. */ @@ -90,19 +90,19 @@ Lisp_Object Vautoload_queue; /* Current number of specbindings allocated in specpdl. */ -ptrdiff_t specpdl_size; +/* ptrdiff_t specpdl_size; */ /* Pointer to beginning of specpdl. */ -struct specbinding *specpdl; +/* struct specbinding *specpdl; */ /* Pointer to first unused element in specpdl. */ -struct specbinding *specpdl_ptr; +/* struct specbinding *specpdl_ptr; */ /* Depth in Lisp evaluations and function calls. */ -static 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 @@ -1051,8 +1051,8 @@ internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object c.tag = tag; c.val = Qnil; c.backlist = backtrace_list; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = 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; @@ -1106,7 +1106,7 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value) /* Unwind the specpdl stack, and then restore the proper set of handlers. */ unbind_to (catchlist->pdlcount, Qnil); - handlerlist = catchlist->handlerlist; + handlerlist = catchlist->f_handlerlist; catchlist = catchlist->next; } while (! last_time); @@ -1127,7 +1127,7 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value) gcpro_level = gcprolist ? gcprolist->level + 1 : 0; #endif backtrace_list = catch->backlist; - lisp_eval_depth = catch->lisp_eval_depth; + lisp_eval_depth = catch->f_lisp_eval_depth; _longjmp (catch->jmp, 1); } @@ -1231,8 +1231,8 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, c.tag = Qnil; c.val = Qnil; c.backlist = backtrace_list; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = 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; @@ -1286,8 +1286,8 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers, c.tag = Qnil; c.val = Qnil; c.backlist = backtrace_list; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = 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; @@ -1324,8 +1324,8 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg, c.tag = Qnil; c.val = Qnil; c.backlist = backtrace_list; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = 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; @@ -1366,8 +1366,8 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), c.tag = Qnil; c.val = Qnil; c.backlist = backtrace_list; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = 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; @@ -1410,8 +1410,8 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), c.tag = Qnil; c.val = Qnil; c.backlist = backtrace_list; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; + c.f_handlerlist = 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; diff --git a/src/lisp.h b/src/lisp.h index a0d47b3..0367d99 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2015,10 +2015,6 @@ struct specbinding Lisp_Object unused; /* Dividing by 16 is faster than by 12 */ }; -extern struct specbinding *specpdl; -extern struct specbinding *specpdl_ptr; -extern ptrdiff_t specpdl_size; - #define SPECPDL_INDEX() (specpdl_ptr - specpdl) /* Everything needed to describe an active condition case. */ @@ -2071,8 +2067,8 @@ struct catchtag struct gcpro *gcpro; jmp_buf jmp; struct backtrace *backlist; - struct handler *handlerlist; - EMACS_INT lisp_eval_depth; + struct handler *f_handlerlist; + EMACS_INT f_lisp_eval_depth; ptrdiff_t pdlcount; int poll_suppress_count; int interrupt_input_blocked; @@ -2081,10 +2077,6 @@ struct catchtag 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. @@ -2140,8 +2132,6 @@ extern Lisp_Object Vascii_canon_table; Every function that can call Feval must protect in this fashion all Lisp_Object variables whose contents will be used again. */ -extern struct gcpro *gcprolist; - struct gcpro { struct gcpro *next; @@ -2246,8 +2236,6 @@ struct gcpro #else -extern int gcpro_level; - #define GCPRO1(varname) \ {gcpro1.next = gcprolist; gcpro1.var = &varname; gcpro1.nvars = 1; \ gcpro1.level = gcpro_level++; \ @@ -2729,7 +2717,6 @@ extern void refill_memory_reserve (void); #endif 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; @@ -2915,10 +2902,6 @@ extern Lisp_Object Vautoload_queue; extern Lisp_Object Vsignaling_function; extern Lisp_Object inhibit_lisp_code; extern int handling_signal; -#if BYTE_MARK_STACK -extern struct catchtag *catchlist; -extern struct handler *handlerlist; -#endif /* To run a normal hook, use the appropriate function from the list below. The calling convention: @@ -3227,7 +3210,6 @@ extern int read_bytecode_char (int); /* Defined in bytecode.c */ extern Lisp_Object Qbytecode; extern void syms_of_bytecode (void); -extern struct byte_stack *byte_stack_list; #if BYTE_MARK_STACK extern void mark_byte_stack (void); #endif @@ -3524,6 +3506,7 @@ extern void *record_xmalloc (size_t); #include "globals.h" +#include "thread.h" /* Check whether it's time for GC, and run it if so. */ diff --git a/src/regex.c b/src/regex.c index 472ef72..b995538 100644 --- a/src/regex.c +++ b/src/regex.c @@ -1235,12 +1235,14 @@ print_double_string (where, string1, size1, string2, size2) # 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. */ /* This has no initializer because initialized variables in Emacs become read-only after dumping. */ reg_syntax_t re_syntax_options; +#endif /* Specify the precise syntax of regexps for compilation. This provides @@ -1260,8 +1262,10 @@ 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 re_char *whitespace_regexp; +#endif void re_set_whitespace_regexp (const char *regexp) @@ -4900,12 +4904,6 @@ re_match (struct re_pattern_buffer *bufp, const char *string, WEAK_ALIAS (__re_match, re_match) #endif /* not emacs */ -#ifdef emacs -/* In Emacs, this is the string or buffer in which we - are matching. It is used for looking up syntax properties. */ -Lisp_Object re_match_object; -#endif - /* re_match_2 matches the compiled pattern in BUFP against the the (virtual) concatenation of STRING1 and STRING2 (of length SIZE1 and SIZE2, respectively). We start matching at POS, and stop diff --git a/src/regex.h b/src/regex.h index e0ede01..91886a8 100644 --- a/src/regex.h +++ b/src/regex.h @@ -166,12 +166,12 @@ typedef unsigned long int reg_syntax_t; some interfaces). When a regexp is compiled, the syntax used is stored in the pattern buffer, so changing this does not affect already-compiled regexps. */ -extern reg_syntax_t re_syntax_options; +/* extern reg_syntax_t re_syntax_options; */ #ifdef emacs /* In Emacs, this is the string or buffer in which we are matching. It is used for looking up syntax properties. */ -extern Lisp_Object re_match_object; +/* extern Lisp_Object re_match_object; */ #endif diff --git a/src/search.c b/src/search.c index 004e599..5df01f6 100644 --- a/src/search.c +++ b/src/search.c @@ -42,7 +42,7 @@ along with GNU Emacs. If not, see . */ struct regexp_cache { struct regexp_cache *next; - Lisp_Object regexp, whitespace_regexp; + Lisp_Object regexp, f_whitespace_regexp; /* Syntax table for which the regexp applies. We need this because of character classes. If this is t, then the compiled pattern is valid for any syntax-table. */ @@ -77,12 +77,12 @@ static struct regexp_cache *searchbuf_head; 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. */ -static struct re_registers search_regs; +/* static struct re_registers search_regs; */ /* 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. */ -static Lisp_Object last_thing_searched; +/* static Lisp_Object last_thing_searched; */ /* Error condition signaled when regexp compile_pattern fails. */ static Lisp_Object Qinvalid_regexp; @@ -129,9 +129,9 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object pattern, Lisp_Object tra cp->buf.multibyte = STRING_MULTIBYTE (pattern); cp->buf.charset_unibyte = charset_unibyte; if (STRINGP (Vsearch_spaces_regexp)) - cp->whitespace_regexp = Vsearch_spaces_regexp; + cp->f_whitespace_regexp = Vsearch_spaces_regexp; else - cp->whitespace_regexp = Qnil; + cp->f_whitespace_regexp = Qnil; /* rms: I think BLOCK_INPUT is not needed here any more, because regex.c defines malloc to call xmalloc. @@ -230,7 +230,7 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp, Lisp_Object tra && cp->posix == posix && (EQ (cp->syntax_table, Qt) || EQ (cp->syntax_table, BVAR (current_buffer, syntax_table))) - && !NILP (Fequal (cp->whitespace_regexp, Vsearch_spaces_regexp)) + && !NILP (Fequal (cp->f_whitespace_regexp, Vsearch_spaces_regexp)) && cp->buf.charset_unibyte == charset_unibyte) break; @@ -2938,9 +2938,9 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */) /* If non-zero the match data have been saved in saved_search_regs during the execution of a sentinel or filter. */ -static int search_regs_saved; -static struct re_registers saved_search_regs; -static Lisp_Object saved_last_thing_searched; +/* static int search_regs_saved; */ +/* static struct re_registers saved_search_regs; */ +/* static Lisp_Object saved_last_thing_searched; */ /* Called from Flooking_at, Fstring_match, search_buffer, Fstore_match_data if asynchronous code (filter or sentinel) is running. */ @@ -3044,10 +3044,10 @@ syms_of_search (void) searchbufs[i].buf.buffer = xmalloc (100); searchbufs[i].buf.fastmap = searchbufs[i].fastmap; searchbufs[i].regexp = Qnil; - searchbufs[i].whitespace_regexp = Qnil; + searchbufs[i].f_whitespace_regexp = Qnil; searchbufs[i].syntax_table = Qnil; staticpro (&searchbufs[i].regexp); - staticpro (&searchbufs[i].whitespace_regexp); + staticpro (&searchbufs[i].f_whitespace_regexp); staticpro (&searchbufs[i].syntax_table); searchbufs[i].next = (i == REGEXP_CACHE_SIZE-1 ? 0 : &searchbufs[i+1]); } diff --git a/src/thread.c b/src/thread.c new file mode 100644 index 0000000..0bd97b4 --- /dev/null +++ b/src/thread.c @@ -0,0 +1,26 @@ +/* Threading code. + Copyright (C) 2012 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" + +struct thread_state the_only_thread; + +struct thread_state *current_thread = &the_only_thread; diff --git a/src/thread.h b/src/thread.h new file mode 100644 index 0000000..b2eb04d --- /dev/null +++ b/src/thread.h @@ -0,0 +1,140 @@ +/* Thread definitions + Copyright (C) 2012 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" + +struct thread_state +{ + /* 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) + + /* m_gcprolist must be the first non-lisp field. */ + /* Recording what needs to be marked for gc. */ + struct gcpro *m_gcprolist; +#define gcprolist (current_thread->m_gcprolist) + + /* 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 analoguous to + gcprolist. */ + 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 backtrace *m_backtrace_list; +#define backtrace_list (current_thread->m_backtrace_list) + + 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) + + /* Count levels of GCPRO to detect failure to UNGCPRO. */ + int m_gcpro_level; +#define gcpro_level (current_thread->m_gcpro_level) + + /* 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. */ + struct specbinding *m_specpdl; +#define specpdl (current_thread->m_specpdl) + + /* Pointer to first unused element in specpdl. */ + struct 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. */ + int 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. */ + 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. */ + /*re_char*/ unsigned char *m_whitespace_regexp; +#define whitespace_regexp (current_thread->m_whitespace_regexp) +}; + +extern struct thread_state *current_thread; + +#endif /* THREAD_H */ diff --git a/src/window.c b/src/window.c index f5622b2..e404b33 100644 --- a/src/window.c +++ b/src/window.c @@ -5296,7 +5296,7 @@ struct save_window_data struct vectorlike_header header; Lisp_Object selected_frame; Lisp_Object current_window; - Lisp_Object current_buffer; + Lisp_Object f_current_buffer; Lisp_Object minibuf_scroll_window; Lisp_Object minibuf_selected_window; Lisp_Object root_window; @@ -5377,7 +5377,7 @@ the return value is nil. Otherwise the value is t. */) data = (struct save_window_data *) XVECTOR (configuration); saved_windows = XVECTOR (data->saved_windows); - new_current_buffer = data->current_buffer; + new_current_buffer = data->f_current_buffer; if (NILP (BVAR (XBUFFER (new_current_buffer), name))) new_current_buffer = Qnil; else @@ -6012,7 +6012,7 @@ saved by this function. */) data->frame_tool_bar_lines = FRAME_TOOL_BAR_LINES (f); data->selected_frame = selected_frame; data->current_window = FRAME_SELECTED_WINDOW (f); - XSETBUFFER (data->current_buffer, current_buffer); + XSETBUFFER (data->f_current_buffer, current_buffer); data->minibuf_scroll_window = minibuf_level > 0 ? Vminibuf_scroll_window : Qnil; data->minibuf_selected_window = minibuf_level > 0 ? minibuf_selected_window : Qnil; data->root_window = FRAME_ROOT_WINDOW (f); @@ -6416,7 +6416,7 @@ compare_window_configurations (Lisp_Object configuration1, Lisp_Object configura || d1->frame_lines != d2->frame_lines || d1->frame_menu_bar_lines != d2->frame_menu_bar_lines || !EQ (d1->selected_frame, d2->selected_frame) - || !EQ (d1->current_buffer, d2->current_buffer) + || !EQ (d1->f_current_buffer, d2->f_current_buffer) || (!ignore_positions && (!EQ (d1->minibuf_scroll_window, d2->minibuf_scroll_window) || !EQ (d1->minibuf_selected_window, d2->minibuf_selected_window)))