dnl checks for header files
AC_CHECK_HEADERS_ONCE(
sys/systeminfo.h
+ sys/sysinfo.h
coff.h pty.h
sys/resource.h
- sys/utsname.h pwd.h utmp.h util.h)
+ sys/utsname.h pwd.h utmp.h util.h sys/prctl.h)
AC_MSG_CHECKING(if personality LINUX32 can be set)
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/personality.h>]], [[personality (PER_LINUX32)]])],
fi
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
++ if test "$emacs_cv_pthread_lib" != no; 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])
+
- ## 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
- ## added to LIBS in configure would never contain the pthreads part,
- ## but the value used in Makefiles might. FIXME?
- ##
- ## -lpthreads seems to be necessary for Xlib in X11R6, and should
- ## be harmless on older versions of X where it happens to exist.
- test "$opsys" = "aix4-2" && \
- test $ac_cv_lib_pthreads_cma_open = yes && \
- LIBS_SYSTEM="$LIBS_SYSTEM -lpthreads"
-
dnl Check for need for bigtoc support on IBM AIX
case ${host_os} in
esac
AC_SUBST(BLESSMAIL_TARGET)
-
- AC_CHECK_FUNCS(accept4 gethostname \
+ OLD_LIBS=$LIBS
+ LIBS="$LIB_PTHREAD $LIB_MATH $LIBS"
+ AC_CHECK_FUNCS(accept4 fchdir gethostname \
getrusage get_current_dir_name \
- lrand48 \
- select getpagesize setlocale \
+ lrand48 random rint \
+ select getpagesize setlocale newlocale \
getrlimit setrlimit shutdown getaddrinfo \
- strsignal setitimer \
+ pthread_sigmask strsignal setitimer \
sendto recvfrom getsockname getpeername getifaddrs freeifaddrs \
- gai_strerror getline getdelim sync \
- difftime posix_memalign \
+ gai_strerror sync \
getpwent endpwent getgrent endgrent \
- touchlock \
-cfmakeraw cfsetspeed copysign __executable_start log2)
+cfmakeraw cfsetspeed copysign __executable_start log2 prctl)
+ LIBS=$OLD_LIBS
- ## Eric Backus <ericb@lsid.hp.com> says, HP-UX 9.x on HP 700 machines
- ## has a broken `rint' in some library versions including math library
- ## version number A.09.05.
- ## You can fix the math library by installing patch number PHSS_4630.
- ## But we can fix it more reliably for Emacs by just not using rint.
- ## We also skip HAVE_RANDOM - see comments in src/conf_post.h.
- case $opsys in
- hpux*) : ;;
- *) AC_CHECK_FUNCS(random rint) ;;
- esac
+ dnl No need to check for aligned_alloc and posix_memalign if using
+ dnl gmalloc.o, as it supplies them, unless we're using hybrid_malloc.
+ dnl Don't use these functions on Darwin as they are incompatible with
+ dnl unexmacosx.c.
+ if (test -z "$GMALLOC_OBJ" || test "$hybrid_malloc" = yes) \
+ && test "$opsys" != darwin; then
+ AC_CHECK_FUNCS([aligned_alloc posix_memalign], [break])
+ fi
dnl Cannot use AC_CHECK_FUNCS
AC_CACHE_CHECK([for __builtin_unwind_init],
Should Emacs use a relocating allocator for buffers? ${REL_ALLOC}
Should Emacs use mmap(2) for buffer allocation? $use_mmap_for_buffers
What window system should Emacs use? ${window_system}
- What toolkit should Emacs use? ${USE_X_TOOLKIT}"
+ What toolkit should Emacs use? ${USE_X_TOOLKIT}
+ Where do we find X Windows header files? ${x_includes:-$emacs_standard_dirs}
+ Where do we find X Windows libraries? ${x_libraries:-$emacs_standard_dirs}"])
- if test -n "${x_includes}"; then
- echo " Where do we find X Windows header files? ${x_includes}"
- else
- echo " Where do we find X Windows header files? Standard dirs"
- fi
- if test -n "${x_libraries}"; then
- echo " Where do we find X Windows libraries? ${x_libraries}"
- else
- echo " Where do we find X Windows libraries? Standard dirs"
- fi
-
- echo " Does Emacs use -lXaw3d? ${HAVE_XAW3D}"
- echo " Does Emacs use -lXpm? ${HAVE_XPM}"
- echo " Does Emacs use -ljpeg? ${HAVE_JPEG}"
- echo " Does Emacs use -ltiff? ${HAVE_TIFF}"
- echo " Does Emacs use a gif library? ${HAVE_GIF} $LIBGIF"
- echo " Does Emacs use -lpng? ${HAVE_PNG}"
- echo " Does Emacs use -lrsvg-2? ${HAVE_RSVG}"
- echo " Does Emacs use imagemagick? ${HAVE_IMAGEMAGICK}"
-
- echo " Does Emacs support sound? ${HAVE_SOUND}"
-
- echo " Does Emacs use -lgpm? ${HAVE_GPM}"
- echo " Does Emacs use -ldbus? ${HAVE_DBUS}"
- echo " Does Emacs use -lgconf? ${HAVE_GCONF}"
- echo " Does Emacs use GSettings? ${HAVE_GSETTINGS}"
- echo " Does Emacs use a file notification library? ${NOTIFY_SUMMARY}"
- echo " Does Emacs use access control lists? ${acl_summary}"
- echo " Does Emacs use -lselinux? ${HAVE_LIBSELINUX}"
- echo " Does Emacs use -lgnutls? ${HAVE_GNUTLS}"
- echo " Does Emacs use -lxml2? ${HAVE_LIBXML2}"
-
- echo " Does Emacs use -lfreetype? ${HAVE_FREETYPE}"
- echo " Does Emacs use -lm17n-flt? ${HAVE_M17N_FLT}"
- echo " Does Emacs use -lotf? ${HAVE_LIBOTF}"
- 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
+ optsep=
+ emacs_config_features=
+ for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \
+ GCONF GSETTINGS NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE M17N_FLT \
+ LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT X11 NS; do
+
+ case $opt in
+ NOTIFY|ACL) eval val=\${${opt}_SUMMARY} ;;
+ CAIRO|TOOLKIT_SCROLL_BARS|X_TOOLKIT) eval val=\${USE_$opt} ;;
+ *) eval val=\${HAVE_$opt} ;;
+ esac
+ case x$val in
+ xno|xnone|x) continue ;;
+ esac
+ case $opt in
+ X_TOOLKIT)
+ case $val in
+ GTK*|LUCID|MOTIF) opt=$val ;;
+ *) continue ;;
+ esac
+ ;;
+ esac
+ AS_VAR_APPEND([emacs_config_features], ["$optsep$opt"])
+ optsep=' '
+ done
+ AC_DEFINE_UNQUOTED(EMACS_CONFIG_FEATURES, "${emacs_config_features}",
+ [Summary of some of the main features enabled by configure.])
+
+ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D}
+ Does Emacs use -lXpm? ${HAVE_XPM}
+ Does Emacs use -ljpeg? ${HAVE_JPEG}
+ Does Emacs use -ltiff? ${HAVE_TIFF}
+ Does Emacs use a gif library? ${HAVE_GIF} $LIBGIF
+ Does Emacs use a png library? ${HAVE_PNG} $LIBPNG
+ Does Emacs use -lrsvg-2? ${HAVE_RSVG}
+ Does Emacs use cairo? ${USE_CAIRO}
+ Does Emacs use imagemagick? ${HAVE_IMAGEMAGICK}
+ Does Emacs support sound? ${HAVE_SOUND}
+ Does Emacs use -lgpm? ${HAVE_GPM}
+ Does Emacs use -ldbus? ${HAVE_DBUS}
+ Does Emacs use -lgconf? ${HAVE_GCONF}
+ Does Emacs use GSettings? ${HAVE_GSETTINGS}
+ Does Emacs use a file notification library? ${NOTIFY_SUMMARY}
+ Does Emacs use access control lists? ${ACL_SUMMARY}
+ Does Emacs use -lselinux? ${HAVE_LIBSELINUX}
+ Does Emacs use -lgnutls? ${HAVE_GNUTLS}
+ Does Emacs use -lxml2? ${HAVE_LIBXML2}
+ Does Emacs use -lfreetype? ${HAVE_FREETYPE}
+ Does Emacs use -lm17n-flt? ${HAVE_M17N_FLT}
+ Does Emacs use -lotf? ${HAVE_LIBOTF}
+ Does Emacs use -lxft? ${HAVE_XFT}
+ Does Emacs directly use zlib? ${HAVE_ZLIB}
+ Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS}
++ Does Emacs have threading support in elisp? ${threads_enabled}
+ "])
if test -n "${EMACSDATA}"; then
- echo " Environment variable EMACSDATA set to: $EMACSDATA"
+ AS_ECHO([" Environment variable EMACSDATA set to: $EMACSDATA"])
fi
if test -n "${EMACSDOC}"; then
- echo " Environment variable EMACSDOC set to: $EMACSDOC"
+ AS_ECHO([" Environment variable EMACSDOC set to: $EMACSDOC"])
fi
echo
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{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{cons}, @code{finalizer}, @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{finalizer},
++@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)
Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
etc. That is, the trailing \".0\"s are insignificant. Also, version
string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
- which is higher than \"1alpha\". Also, \"-CVS\" and \"-NNN\" are treated
- as alpha versions."
+ which is higher than \"1alpha\", which is higher than \"1snapshot\".
+ Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions."
(version-list-= (version-to-list v1) (version-to-list v2)))
+ (defvar package--builtin-versions
+ ;; Mostly populated by loaddefs.el via autoload-builtin-package-versions.
+ (purecopy `((emacs . ,(version-to-list emacs-version))))
+ "Alist giving the version of each versioned builtin package.
+ I.e. each element of the list is of the form (NAME . VERSION) where
+ NAME is the package name as a symbol, and VERSION is its version
+ as a list.")
+
+ (defun package--description-file (dir)
+ (concat (let ((subdir (file-name-nondirectory
+ (directory-file-name dir))))
+ (if (string-match "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)" subdir)
+ (match-string 1 subdir) subdir))
+ "-pkg.el"))
+
+\f
+;;; Thread support.
+
+(defmacro with-mutex (mutex &rest body)
+ "Invoke BODY with MUTEX held, releasing MUTEX when done.
+This is the simplest safe way to acquire and release a mutex."
+ (declare (indent 1) (debug t))
+ (let ((sym (make-symbol "mutex")))
+ `(let ((,sym ,mutex))
+ (mutex-lock ,sym)
+ (unwind-protect
+ (progn ,@body)
+ (mutex-unlock ,sym)))))
+
\f
;;; Misc.
(defconst menu-bar-separator '("--")
if (size & PSEUDOVECTOR_FLAG)
{
if (PSEUDOVECTOR_TYPEP (&v->header, PVEC_BOOL_VECTOR))
- size = (bool_header_size
- + (((struct Lisp_Bool_Vector *) v)->size
- + BOOL_VECTOR_BITS_PER_CHAR - 1)
- / BOOL_VECTOR_BITS_PER_CHAR);
+ {
+ struct Lisp_Bool_Vector *bv = (struct Lisp_Bool_Vector *) v;
+ ptrdiff_t word_bytes = (bool_vector_words (bv->size)
+ * sizeof (bits_word));
+ ptrdiff_t boolvec_bytes = bool_header_size + word_bytes;
+ verify (header_size <= bool_header_size);
+ nwords = (boolvec_bytes - header_size + word_size - 1) / word_size;
+ }
else
- size = (header_size
- + ((size & PSEUDOVECTOR_SIZE_MASK)
- + ((size & PSEUDOVECTOR_REST_MASK)
- >> PSEUDOVECTOR_SIZE_BITS)) * word_size);
+ nwords = ((size & PSEUDOVECTOR_SIZE_MASK)
+ + ((size & PSEUDOVECTOR_REST_MASK)
+ >> PSEUDOVECTOR_SIZE_BITS));
}
else
- size = header_size + size * word_size;
- return vroundup (size);
+ nwords = size;
+ return vroundup (header_size + word_size * nwords);
+ }
+
+ /* Release extra resources still in use by VECTOR, which may be any
- vector-like object. For now, this is used just to free data in
- font objects. */
++ vector-like object. */
+
+ static void
+ cleanup_vector (struct Lisp_Vector *vector)
+ {
+ detect_suspicious_free (vector);
+ if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT)
+ && ((vector->header.size & PSEUDOVECTOR_SIZE_MASK)
+ == FONT_OBJECT_MAX))
+ {
+ struct font_driver *drv = ((struct font *) vector)->driver;
+
+ /* The font driver might sometimes be NULL, e.g. if Emacs was
+ interrupted before it had time to set it up. */
+ if (drv)
+ {
+ /* Attempt to catch subtle bugs like Bug#16140. */
+ eassert (valid_font_driver (drv));
+ drv->close ((struct font *) vector);
+ }
+ }
++
++ if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
++ finalize_one_thread ((struct thread_state *) vector);
++ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
++ finalize_one_mutex ((struct Lisp_Mutex *) vector);
++ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
++ finalize_one_condvar ((struct Lisp_CondVar *) vector);
}
/* Reclaim space used by unmarked vectors. */
#ifdef GC_MARK_SECONDARY_STACK
GC_MARK_SECONDARY_STACK ();
#endif
-
- #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
- check_gcpros ();
- #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.
- #else /* GC_MARK_STACK == 0 */
-
- #define mark_maybe_object(obj) emacs_abort ()
-
- #endif /* GC_MARK_STACK != 0 */
-
++
+ It is invalid to run any Lisp code or to allocate any GC memory
+ from FUNC. */
+
+void
+flush_stack_call_func (void (*func) (void *arg), void *arg)
+{
+ void *end;
+ struct thread_state *self = current_thread;
+
+#ifdef HAVE___BUILTIN_UNWIND_INIT
+ /* Force callee-saved registers and register windows onto the stack.
+ This is the preferred method if available, obviating the need for
+ machine dependent methods. */
+ __builtin_unwind_init ();
+ end = &end;
+#else /* not HAVE___BUILTIN_UNWIND_INIT */
+#ifndef GC_SAVE_REGISTERS_ON_STACK
+ /* jmp_buf may not be aligned enough on darwin-ppc64 */
+ union aligned_jmpbuf {
+ Lisp_Object o;
+ sys_jmp_buf j;
+ } j;
+ volatile bool stack_grows_down_p = (char *) &j > (char *) stack_bottom;
+#endif
+ /* This trick flushes the register windows so that all the state of
+ the process is contained in the stack. */
+ /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
+ needed on ia64 too. See mach_dep.c, where it also says inline
+ assembler doesn't work with relevant proprietary compilers. */
+#ifdef __sparc__
+#if defined (__sparc64__) && defined (__FreeBSD__)
+ /* FreeBSD does not have a ta 3 handler. */
+ asm ("flushw");
+#else
+ asm ("ta 3");
+#endif
+#endif
+
+ /* Save registers that we need to see on the stack. We need to see
+ registers used to hold register variables and registers used to
+ pass parameters. */
+#ifdef GC_SAVE_REGISTERS_ON_STACK
+ GC_SAVE_REGISTERS_ON_STACK (end);
+#else /* not GC_SAVE_REGISTERS_ON_STACK */
+
+#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
+ setjmp will definitely work, test it
+ and print a message with the result
+ of the test. */
+ if (!setjmp_tested_p)
+ {
+ setjmp_tested_p = 1;
+ test_setjmp ();
+ }
+#endif /* GC_SETJMP_WORKS */
+
+ sys_setjmp (j.j);
+ end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
+#endif /* not GC_SAVE_REGISTERS_ON_STACK */
+#endif /* not HAVE___BUILTIN_UNWIND_INIT */
+
+ self->stack_top = end;
+ (*func) (arg);
+
+ eassert (current_thread == self);
+}
+
+ static bool
+ c_symbol_p (struct Lisp_Symbol *sym)
+ {
+ char *lispsym_ptr = (char *) lispsym;
+ char *sym_ptr = (char *) sym;
+ ptrdiff_t lispsym_offset = sym_ptr - lispsym_ptr;
+ return 0 <= lispsym_offset && lispsym_offset < sizeof lispsym;
+ }
/* Determine whether it is safe to access memory at address P. */
static int
for (i = 0; i < staticidx; i++)
mark_object (*staticvec[i]);
- mark_threads ();
+ mark_pinned_symbols ();
- mark_specpdl ();
mark_terminals ();
mark_kboards ();
++ mark_threads ();
#ifdef USE_GTK
xg_mark_data ();
mark_fringe_data ();
#endif
- #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- FIXME;
- mark_stack ();
- #endif
+ /* Everything is now marked, except for the data in font caches,
+ undo lists, and finalizers. The first two are compacted by
+ removing an items which aren't reachable otherwise. */
+
+ compact_font_caches ();
- /* Everything is now marked, except for the things that require special
- finalization, i.e. the undo_list.
- Look thru every buffer's undo list
- for elements that update markers that were not marked,
- and delete them. */
FOR_EACH_BUFFER (nextb)
{
- /* If a buffer's undo list is Qt, that means that undo is
- turned off in that buffer. Calling truncate_undo_list on
- Qt tends to return NULL, which effectively turns undo back on.
- So don't call truncate_undo_list if undo_list is Qt. */
- if (! EQ (nextb->INTERNAL_FIELD (undo_list), Qt))
- {
- Lisp_Object tail, prev;
- tail = nextb->INTERNAL_FIELD (undo_list);
- prev = Qnil;
- while (CONSP (tail))
- {
- if (CONSP (XCAR (tail))
- && MARKERP (XCAR (XCAR (tail)))
- && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
- {
- if (NILP (prev))
- nextb->INTERNAL_FIELD (undo_list) = tail = XCDR (tail);
- else
- {
- tail = XCDR (tail);
- XSETCDR (prev, tail);
- }
- }
- else
- {
- prev = tail;
- tail = XCDR (tail);
- }
- }
- }
- /* Now that we have stripped the elements that need not be in the
- undo_list any more, we can finally mark the list. */
- mark_object (nextb->INTERNAL_FIELD (undo_list));
+ if (!EQ (BVAR (nextb, undo_list), Qt))
+ bset_undo_list (nextb, compact_undo_list (BVAR (nextb, undo_list)));
+ /* Now that we have stripped the elements that need not be
+ in the undo_list any more, we can finally mark the list. */
+ mark_object (BVAR (nextb, undo_list));
}
- gc_sweep ();
+ /* Now pre-sweep finalizers. Here, we add any unmarked finalizers
+ to doomed_finalizers so we can run their associated functions
+ after GC. It's important to scan finalizers at this stage so
+ that we can be sure that unmarked finalizers are really
+ unreachable except for references from their associated functions
+ and from other finalizers. */
- /* Clear the mark bits that we set in certain root slots. */
+ queue_doomed_finalizers (&doomed_finalizers, &finalizers);
+ mark_finalizer_list (&doomed_finalizers);
+
+ gc_sweep ();
- relocate_byte_stack ();
+ unmark_threads ();
+
+ /* Clear the mark bits that we set in certain root slots. */
VECTOR_UNMARK (&buffer_defaults);
VECTOR_UNMARK (&buffer_local_symbols);
#include "keymap.h"
#include "frame.h"
-struct buffer *current_buffer; /* The current buffer. */
-
+ #ifdef WINDOWSNT
+ #include "w32heap.h" /* for mmap_* */
+ #endif
+
/* First buffer in chain of all buffers (in reverse order of creation).
Threaded through ->header.next.buffer. */
/* 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. Signaling an error truncates the list analogous to
- gcprolist. */
+ processing byte-code, and it removes the entry again when it is
+ done. Signaling an error truncates the list. */
-struct byte_stack *byte_stack_list;
+/* struct byte_stack *byte_stack_list; */
\f
- /* Mark objects on byte_stack_list. Called during GC. */
-
- #if BYTE_MARK_STACK
- void
- mark_byte_stack (struct byte_stack *stack)
- {
- Lisp_Object *obj;
-
- 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
- which opcode this is, record the value of `stack', and walk
- up the stack in a debugger, stopping in frames of Fbyte_code.
- The culprit is found in the frame of Fbyte_code where the
- address of its local variable `stack' is equal to the
- recorded value of `stack' here. */
- eassert (stack->top);
-
- for (obj = stack->bottom; obj <= stack->top; ++obj)
- mark_object (*obj);
-
- mark_object (stack->byte_string);
- mark_object (stack->constants);
- }
- }
- #endif
-
- /* Unmark objects in the stacks on byte_stack_list. Relocate program
- counters. Called when GC has completed. */
+ /* Relocate program counters in the stacks on byte_stack_list. Called
+ when GC has completed. */
void
- unmark_byte_stack (struct byte_stack *stack)
-relocate_byte_stack (void)
++relocate_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))
{
DEFSYM (Qchar_table, "char-table");
DEFSYM (Qbool_vector, "bool-vector");
DEFSYM (Qhash_table, "hash-table");
- DEFSYM (Qmisc, "misc");
+ DEFSYM (Qthread, "thread");
+ DEFSYM (Qmutex, "mutex");
+ DEFSYM (Qcondition_variable, "condition-variable");
DEFSYM (Qdefun, "defun");
#ifdef WINDOWSNT
#include <fcntl.h>
#include <sys/socket.h>
-#include "w32.h"
+ #include <mbstring.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"
#ifdef DAEMON_MUST_EXEC
char dname_arg2[80];
#endif
- char *ch_to_dir;
+ char *ch_to_dir = 0;
+
+ /* If we use --chdir, this records the original directory. */
+ char *original_pwd = 0;
- stack_base = &dummy;
+ /* Record (approximately) where the stack begins. */
+ stack_bottom = &stack_bottom_variable;
- #ifdef G_SLICE_ALWAYS_MALLOC
- /* This is used by the Cygwin build. It's not needed starting with
- cygwin-1.7.24, but it doesn't do any harm. */
- xputenv ("G_SLICE=always-malloc");
+ #ifndef CANNOT_DUMP
+ might_dump = !initialized;
#endif
#ifdef GNU_LINUX
setrlimit (RLIMIT_STACK, &rlim);
}
- #endif /* HAVE_SETRLIMIT and RLIMIT_STACK */
+ #endif /* HAVE_SETRLIMIT and RLIMIT_STACK and not CYGWIN */
- /* Record (approximately) where the stack begins. */
- stack_bottom = &stack_bottom_variable;
-
clearerr (stdin);
- #ifndef SYSTEM_MALLOC
+ emacs_backtrace (-1);
+
+ #if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
/* Arrange to get warning messages as memory fills up. */
memory_warnings (0, malloc_warning);
#include "commands.h"
#include "keyboard.h"
#include "dispextern.h"
- #include "frame.h" /* For XFRAME. */
-
- #if HAVE_X_WINDOWS
- #include "xterm.h"
- #endif
-
- /* #if !BYTE_MARK_STACK */
- /* static */
- /* #endif */
- /* struct catchtag *catchlist; */
+ #include "buffer.h"
- /* 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. */
+ /* Chain of condition and catch handlers currently in effect. */
- /* #if !BYTE_MARK_STACK */
- /* static */
- /* #endif */
-struct handler *handlerlist;
+/* struct handler *handlerlist; */
- #ifdef DEBUG_GCPRO
- /* Count levels of GCPRO to detect failure to UNGCPRO. */
- int gcpro_level;
- #endif
-
- Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp;
- Lisp_Object Qinhibit_quit;
- Lisp_Object Qand_rest;
- static Lisp_Object Qand_optional;
- static Lisp_Object Qinhibit_debugger;
- static Lisp_Object Qdeclare;
- Lisp_Object Qinternal_interpreter_environment, Qclosure;
-
- static Lisp_Object Qdebug;
-
- /* This holds either the symbol `run-hooks' or nil.
- It is nil at an early stage of startup, and when Emacs
- is shutting down. */
-
- Lisp_Object Vrun_hooks;
-
/* Non-nil means record all fset's and provide's, to be undone
if the file being autoloaded is not fully loaded.
They are recorded by being consed onto the front of Vautoload_queue:
/* Depth in Lisp evaluations and function calls. */
- /* static EMACS_INT lisp_eval_depth; */
-EMACS_INT lisp_eval_depth;
++/* 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
Vrun_hooks = Qnil;
}
-static struct handler handlerlist_sentinel;
++/* static struct handler handlerlist_sentinel; */
+
void
init_eval (void)
{
+ byte_stack_list = 0;
specpdl_ptr = specpdl;
- catchlist = 0;
- handlerlist = 0;
+ { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
+ This is important since handlerlist->nextfree holds the freelist
+ which would otherwise leak every time we unwind back to top-level. */
+ struct handler *c;
- handlerlist = handlerlist_sentinel.nextfree = &handlerlist_sentinel;
++ handlerlist_sentinel = xzalloc (sizeof (struct handler));
++ handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
+ PUSH_HANDLER (c, Qunbound, CATCHER);
- eassert (c == &handlerlist_sentinel);
- handlerlist_sentinel.nextfree = NULL;
- handlerlist_sentinel.next = NULL;
++ eassert (c == handlerlist_sentinel);
++ handlerlist_sentinel->nextfree = NULL;
++ handlerlist_sentinel->next = NULL;
+ }
Vquit_flag = Qnil;
debug_on_next_call = 0;
lisp_eval_depth = 0;
}
while (! last_time);
+ eassert (handlerlist == catch);
+
byte_stack_list = catch->byte_stack;
- gcprolist = catch->gcpro;
- #ifdef DEBUG_GCPRO
- gcpro_level = gcprolist ? gcprolist->level + 1 : 0;
- #endif
- lisp_eval_depth = catch->lisp_eval_depth;
+ lisp_eval_depth = catch->f_lisp_eval_depth;
sys_longjmp (catch->jmp, 1);
}
}
else
{
- if (catchlist != 0)
- if (handlerlist != &handlerlist_sentinel)
++ if (handlerlist != handlerlist_sentinel)
+ /* FIXME: This will come right back here if there's no `top-level'
+ catcher. A better solution would be to abort here, and instead
+ add a catch-all condition handler so we never come here. */
Fthrow (Qtop_level, Qt);
}
return 0;
}
- /* `specpdl_ptr->symbol' is a field which describes which variable is
+void
+do_specbind (struct Lisp_Symbol *sym, union specbinding *bind,
+ Lisp_Object value)
+{
+ switch (sym->redirect)
+ {
+ case SYMBOL_PLAINVAL:
+ if (!sym->constant)
+ SET_SYMBOL_VAL (sym, value);
+ else
+ 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 (specpdl_symbol (bind)))
+ {
+ Lisp_Object where;
+
+ where = XCAR (XCDR (specpdl_symbol (bind)));
+ if (NILP (where)
+ && sym->redirect == SYMBOL_FORWARDED)
+ {
+ Fset_default (XCAR (specpdl_symbol (bind)), value);
+ return;
+ }
+ }
+
+ set_internal (specpdl_symbol (bind), value, Qnil, 1);
+ break;
+
+ default:
+ abort ();
+ }
+}
+
+ /* `specpdl_ptr' describes which variable is
let-bound, so it can be properly undone when we unbind_to.
- It can have the following two shapes:
- - SYMBOL : if it's a plain symbol, it means that we have let-bound
- a symbol that is not buffer-local (at least at the time
- the let binding started). Note also that it should not be
+ It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
+ - SYMBOL is the variable being bound. Note that it should not be
aliased (i.e. when let-binding V1 that's aliased to V2, we want
to record V2 here).
- - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
- variable SYMBOL which can be buffer-local. WHERE tells us
- which buffer is affected (or nil if the let-binding affects the
- global value of the variable) and BUFFER tells us which buffer was
- current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
- BUFFER did not yet have a buffer-local value). */
+ - WHERE tells us in which buffer the binding took place.
+ This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
+ buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
+ i.e. bindings to the default value of a variable which can be
+ buffer-local. */
void
specbind (Lisp_Object symbol, Lisp_Object value)
from the debugger. */
return unbind_to (count, eval_sub (exp));
}
+
+ DEFUN ("backtrace--locals", Fbacktrace__locals, Sbacktrace__locals, 1, 2, NULL,
+ doc: /* Return names and values of local variables of a stack frame.
+ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
+ (Lisp_Object nframes, Lisp_Object base)
+ {
+ union specbinding *frame = get_backtrace_frame (nframes, base);
+ union specbinding *prevframe
+ = get_backtrace_frame (make_number (XFASTINT (nframes) - 1), base);
+ ptrdiff_t distance = specpdl_ptr - frame;
+ Lisp_Object result = Qnil;
+ eassert (distance >= 0);
+
+ if (!backtrace_p (prevframe))
+ error ("Activation frame not found!");
+ if (!backtrace_p (frame))
+ error ("Activation frame not found!");
+
+ /* The specpdl entries normally contain the symbol being bound along with its
+ `old_value', so it can be restored. The new value to which it is bound is
+ available in one of two places: either in the current value of the
+ variable (if it hasn't been rebound yet) or in the `old_value' slot of the
+ next specpdl entry for it.
+ `backtrace_eval_unrewind' happens to swap the role of `old_value'
+ and "new value", so we abuse it here, to fetch the new value.
+ It's ugly (we'd rather not modify global data) and a bit inefficient,
+ but it does the job for now. */
+ backtrace_eval_unrewind (distance);
+
+ /* Grab values. */
+ {
+ union specbinding *tmp = prevframe;
+ for (; tmp > frame; tmp--)
+ {
+ switch (tmp->kind)
+ {
+ case SPECPDL_LET:
+ case SPECPDL_LET_DEFAULT:
+ case SPECPDL_LET_LOCAL:
+ {
+ Lisp_Object sym = specpdl_symbol (tmp);
+ Lisp_Object val = specpdl_old_value (tmp);
+ if (EQ (sym, Qinternal_interpreter_environment))
+ {
+ Lisp_Object env = val;
+ for (; CONSP (env); env = XCDR (env))
+ {
+ Lisp_Object binding = XCAR (env);
+ if (CONSP (binding))
+ result = Fcons (Fcons (XCAR (binding),
+ XCDR (binding)),
+ result);
+ }
+ }
+ else
+ result = Fcons (Fcons (sym, val), result);
+ }
+ break;
+
+ case SPECPDL_UNWIND:
+ case SPECPDL_UNWIND_PTR:
+ case SPECPDL_UNWIND_INT:
+ case SPECPDL_UNWIND_VOID:
+ case SPECPDL_BACKTRACE:
+ break;
+
+ default:
+ emacs_abort ();
+ }
+ }
+ }
+
+ /* Restore values from specpdl to original place. */
+ backtrace_eval_unrewind (-distance);
+
+ return result;
+ }
+
\f
void
-mark_specpdl (void)
+mark_specpdl (union specbinding *first, union specbinding *ptr)
{
union specbinding *pdl;
- for (pdl = specpdl; pdl != specpdl_ptr; pdl++)
+ for (pdl = first; pdl != ptr; pdl++)
{
switch (pdl->kind)
{
case SPECPDL_LET:
mark_object (specpdl_symbol (pdl));
mark_object (specpdl_old_value (pdl));
+ mark_object (specpdl_saved_value (pdl));
break;
+
+ case SPECPDL_UNWIND_PTR:
+ case SPECPDL_UNWIND_INT:
+ case SPECPDL_UNWIND_VOID:
+ break;
+
+ default:
+ emacs_abort ();
}
}
}
#include <c-ctype.h>
#include "lisp.h"
- #include "character.h"
#include "buffer.h"
#include "coding.h"
- #include "systime.h"
#ifdef WINDOWSNT
-#include <share.h>
-#include <sys/socket.h> /* for fcntl */
#include "w32.h" /* for dostounix_filename */
#endif
#include <limits.h>
#include <intprops.h>
+ #include <verify.h>
+#include "systhread.h"
+
INLINE_HEADER_BEGIN
- #ifndef LISP_INLINE
- # define LISP_INLINE INLINE
+
+ /* Define a TYPE constant ID as an externally visible name. Use like this:
+
+ DEFINE_GDB_SYMBOL_BEGIN (TYPE, ID)
+ # define ID (some integer preprocessor expression of type TYPE)
+ DEFINE_GDB_SYMBOL_END (ID)
+
+ This hack is for the benefit of compilers that do not make macro
+ definitions or enums visible to the debugger. It's used for symbols
+ that .gdbinit needs. */
+
+ #define DECLARE_GDB_SYM(type, id) type const id EXTERNALLY_VISIBLE
+ #ifdef MAIN_PROGRAM
+ # define DEFINE_GDB_SYMBOL_BEGIN(type, id) DECLARE_GDB_SYM (type, id)
+ # define DEFINE_GDB_SYMBOL_END(id) = id;
+ #else
+ # define DEFINE_GDB_SYMBOL_BEGIN(type, id) extern DECLARE_GDB_SYM (type, id)
+ # define DEFINE_GDB_SYMBOL_END(val) ;
#endif
/* The ubiquitous max and min macros. */
/* If a struct type is not wanted, define Lisp_Object as just a number. */
typedef EMACS_INT Lisp_Object;
- #define LISP_INITIALLY_ZERO 0
- enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = 0 };
+ #define LISP_INITIALLY(i) (i)
+ enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false };
#endif /* CHECK_LISP_OBJECT_TYPE */
- <http://debbugs.gnu.org/cgi/bugreport.cgi?bug=8546>. */
+ #define LISP_INITIALLY_ZERO LISP_INITIALLY (0)
+ \f
+ /* Forward declarations. */
+
+ /* Defined in this file. */
+ union Lisp_Fwd;
+ INLINE bool BOOL_VECTOR_P (Lisp_Object);
+ INLINE bool BUFFER_OBJFWDP (union Lisp_Fwd *);
+ INLINE bool BUFFERP (Lisp_Object);
+ INLINE bool CHAR_TABLE_P (Lisp_Object);
+ INLINE Lisp_Object CHAR_TABLE_REF_ASCII (Lisp_Object, ptrdiff_t);
+ INLINE bool (CONSP) (Lisp_Object);
+ INLINE bool (FLOATP) (Lisp_Object);
+ INLINE bool functionp (Lisp_Object);
+ INLINE bool (INTEGERP) (Lisp_Object);
+ INLINE bool (MARKERP) (Lisp_Object);
+ INLINE bool (MISCP) (Lisp_Object);
+ INLINE bool (NILP) (Lisp_Object);
+ INLINE bool OVERLAYP (Lisp_Object);
+ INLINE bool PROCESSP (Lisp_Object);
+ INLINE bool PSEUDOVECTORP (Lisp_Object, int);
+ INLINE bool SAVE_VALUEP (Lisp_Object);
+ INLINE bool FINALIZERP (Lisp_Object);
+ INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t,
+ Lisp_Object);
+ INLINE bool STRINGP (Lisp_Object);
+ INLINE bool SUB_CHAR_TABLE_P (Lisp_Object);
+ INLINE bool SUBRP (Lisp_Object);
+ INLINE bool (SYMBOLP) (Lisp_Object);
+ INLINE bool (VECTORLIKEP) (Lisp_Object);
+ INLINE bool WINDOWP (Lisp_Object);
+ INLINE bool TERMINALP (Lisp_Object);
++INLINE bool THREADP (Lisp_Object);
++INLINE bool MUTEXP (Lisp_Object);
++INLINE bool CONDVARP (Lisp_Object);
+ INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object);
+ INLINE struct Lisp_Finalizer *XFINALIZER (Lisp_Object);
+ INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object);
+ INLINE void *(XUNTAG) (Lisp_Object, int);
+
+ /* Defined in chartab.c. */
+ extern Lisp_Object char_table_ref (Lisp_Object, int);
+ extern void char_table_set (Lisp_Object, int, Lisp_Object);
+
+ /* Defined in data.c. */
+ extern _Noreturn Lisp_Object wrong_type_argument (Lisp_Object, Lisp_Object);
+ extern _Noreturn void wrong_choice (Lisp_Object, Lisp_Object);
+
+ /* Defined in emacs.c. */
+ extern bool might_dump;
+ /* True means Emacs has already been initialized.
+ Used during startup to detect startup of dumped Emacs. */
+ extern bool initialized;
+
+ /* Defined in floatfns.c. */
+ extern double extract_float (Lisp_Object);
+
+ \f
+ /* Interned state of a symbol. */
+
+ enum symbol_interned
+ {
+ SYMBOL_UNINTERNED = 0,
+ SYMBOL_INTERNED = 1,
+ SYMBOL_INTERNED_IN_INITIAL_OBARRAY = 2
+ };
+
+ enum symbol_redirect
+ {
+ SYMBOL_PLAINVAL = 4,
+ SYMBOL_VARALIAS = 1,
+ SYMBOL_LOCALIZED = 2,
+ SYMBOL_FORWARDED = 3
+ };
+
+ struct Lisp_Symbol
+ {
+ bool_bf gcmarkbit : 1;
+
+ /* Indicates where the value can be found:
+ 0 : it's a plain var, the value is in the `value' field.
+ 1 : it's a varalias, the value is really in the `alias' symbol.
+ 2 : it's a localized var, the value is in the `blv' object.
+ 3 : it's a forwarding variable, the value is in `forward'. */
+ ENUM_BF (symbol_redirect) redirect : 3;
+
+ /* Non-zero means symbol is constant, i.e. changing its value
+ should signal an error. If the value is 3, then the var
+ can be changed, but only by `defconst'. */
+ unsigned constant : 2;
+
+ /* Interned state of the symbol. This is an enumerator from
+ enum symbol_interned. */
+ unsigned interned : 2;
+
+ /* True means that this variable has been explicitly declared
+ special (with `defvar' etc), and shouldn't be lexically bound. */
+ bool_bf declared_special : 1;
+
+ /* True if pointed to from purespace and hence can't be GC'd. */
+ bool_bf pinned : 1;
+
+ /* The symbol's name, as a Lisp string. */
+ Lisp_Object name;
+
+ /* Value of the symbol or Qunbound if unbound. Which alternative of the
+ union is used depends on the `redirect' field above. */
+ union {
+ Lisp_Object value;
+ struct Lisp_Symbol *alias;
+ struct Lisp_Buffer_Local_Value *blv;
+ union Lisp_Fwd *fwd;
+ } val;
+
+ /* Function value of the symbol or Qnil if not fboundp. */
+ Lisp_Object function;
+
+ /* The symbol's property list. */
+ Lisp_Object plist;
+
+ /* Next symbol in obarray bucket, if the symbol is interned. */
+ struct Lisp_Symbol *next;
+ };
+
+ /* Declare a Lisp-callable function. The MAXARGS parameter has the same
+ meaning as in the DEFUN macro, and is used to construct a prototype. */
+ /* We can use the same trick as in the DEFUN macro to generate the
+ appropriate prototype. */
+ #define EXFUN(fnname, maxargs) \
+ extern Lisp_Object fnname DEFUN_ARGS_ ## maxargs
+
+ /* Note that the weird token-substitution semantics of ANSI C makes
+ this work for MANY and UNEVALLED. */
+ #define DEFUN_ARGS_MANY (ptrdiff_t, Lisp_Object *)
+ #define DEFUN_ARGS_UNEVALLED (Lisp_Object)
+ #define DEFUN_ARGS_0 (void)
+ #define DEFUN_ARGS_1 (Lisp_Object)
+ #define DEFUN_ARGS_2 (Lisp_Object, Lisp_Object)
+ #define DEFUN_ARGS_3 (Lisp_Object, Lisp_Object, Lisp_Object)
+ #define DEFUN_ARGS_4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object)
+ #define DEFUN_ARGS_5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \
+ Lisp_Object)
+ #define DEFUN_ARGS_6 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \
+ Lisp_Object, Lisp_Object)
+ #define DEFUN_ARGS_7 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \
+ Lisp_Object, Lisp_Object, Lisp_Object)
+ #define DEFUN_ARGS_8 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \
+ Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object)
+
+ /* Yield an integer that contains TAG along with PTR. */
+ #define TAG_PTR(tag, ptr) \
+ ((USE_LSB_TAG ? (tag) : (EMACS_UINT) (tag) << VALBITS) + (uintptr_t) (ptr))
+
+ /* Yield an integer that contains a symbol tag along with OFFSET.
+ OFFSET should be the offset in bytes from 'lispsym' to the symbol. */
+ #define TAG_SYMOFFSET(offset) TAG_PTR (Lisp_Symbol, offset)
+
+ /* XLI_BUILTIN_LISPSYM (iQwhatever) is equivalent to
+ XLI (builtin_lisp_symbol (Qwhatever)),
+ except the former expands to an integer constant expression. */
+ #define XLI_BUILTIN_LISPSYM(iname) TAG_SYMOFFSET ((iname) * sizeof *lispsym)
+
+ /* Declare extern constants for Lisp symbols. These can be helpful
+ when using a debugger like GDB, on older platforms where the debug
+ format does not represent C macros. */
+ #define DEFINE_LISP_SYMBOL(name) \
+ DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \
+ DEFINE_GDB_SYMBOL_END (LISP_INITIALLY (XLI_BUILTIN_LISPSYM (i##name)))
+
+ /* By default, define macros for Qt, etc., as this leads to a bit
+ better performance in the core Emacs interpreter. A plugin can
+ define DEFINE_NON_NIL_Q_SYMBOL_MACROS to be false, to be portable to
+ other Emacs instances that assign different values to Qt, etc. */
+ #ifndef DEFINE_NON_NIL_Q_SYMBOL_MACROS
+ # define DEFINE_NON_NIL_Q_SYMBOL_MACROS true
+ #endif
+
+ #include "globals.h"
+
+/* Header of vector-like objects. This documents the layout constraints on
+ vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
+ compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
+ and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
+ because when two such pointers potentially alias, a compiler won't
+ incorrectly reorder loads and stores to their size fields. See
++ Bug#8546. */
+struct vectorlike_header
+ {
+ /* The only field contains various pieces of information:
+ - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
+ - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
+ vector (0) or a pseudovector (1).
+ - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
+ of slots) of the vector.
+ - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
+ - a) pseudovector subtype held in PVEC_TYPE_MASK field;
+ - b) number of Lisp_Objects slots at the beginning of the object
+ held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
+ traced by the GC;
+ - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
+ measured in word_size units. Rest fields may also include
+ Lisp_Objects, but these objects usually needs some special treatment
+ during GC.
+ There are some exceptions. For PVEC_FREE, b) is always zero. For
+ PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
+ Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
+ 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
+ ptrdiff_t size;
+ };
+
+#include "thread.h"
+
/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa.
At the machine level, these operations are no-ops. */
- LISP_MACRO_DEFUN (XLI, EMACS_INT, (Lisp_Object o), (o))
- LISP_MACRO_DEFUN (XIL, Lisp_Object, (EMACS_INT i), (i))
+
+ INLINE EMACS_INT
+ (XLI) (Lisp_Object o)
+ {
+ return lisp_h_XLI (o);
+ }
+
+ INLINE Lisp_Object
+ (XIL) (EMACS_INT i)
+ {
+ return lisp_h_XIL (i);
+ }
/* In the size word of a vector, this bit means the vector has been marked. */
return XUNTAG (a, Lisp_Vectorlike);
}
- LISP_INLINE struct thread_state *
++INLINE struct thread_state *
+XTHREAD (Lisp_Object a)
+{
+ eassert (THREADP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+}
+
- LISP_INLINE struct Lisp_Mutex *
++INLINE struct Lisp_Mutex *
+XMUTEX (Lisp_Object a)
+{
+ eassert (MUTEXP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+}
+
- LISP_INLINE struct Lisp_CondVar *
++INLINE struct Lisp_CondVar *
+XCONDVAR (Lisp_Object a)
+{
+ eassert (CONDVARP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+}
+
/* Construct a Lisp_Object from a value or address. */
- LISP_INLINE Lisp_Object
+ INLINE Lisp_Object
make_lisp_ptr (void *ptr, enum Lisp_Type type)
{
- EMACS_UINT utype = type;
- EMACS_UINT typebits = USE_LSB_TAG ? type : utype << VALBITS;
- Lisp_Object a = XIL (typebits | (uintptr_t) ptr);
+ Lisp_Object a = XIL (TAG_PTR (type, ptr));
eassert (XTYPE (a) == type && XUNTAG (a, type) == ptr);
return a;
}
#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))
+#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX))
+#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR))
- /* Type checking. */
+ /* Efficiently convert a pointer to a Lisp object and back. The
+ pointer is represented as a Lisp integer, so the garbage collector
+ does not know about it. The pointer should not have both Lisp_Int1
+ bits set, which makes this conversion inherently unportable. */
+
+ INLINE void *
+ XINTPTR (Lisp_Object a)
+ {
+ return XUNTAG (a, Lisp_Int0);
+ }
- LISP_MACRO_DEFUN_VOID (CHECK_TYPE, (int ok, Lisp_Object Qxxxp, Lisp_Object x),
- (ok, Qxxxp, x))
+ INLINE Lisp_Object
+ make_pointer_integer (void *p)
+ {
+ Lisp_Object a = XIL (TAG_PTR (Lisp_Int0, p));
+ eassert (INTEGERP (a) && XINTPTR (a) == p);
+ return a;
+ }
- /* Deprecated and will be removed soon. */
+ /* Type checking. */
- #define INTERNAL_FIELD(field) field ## _
+ INLINE void
+ (CHECK_TYPE) (int ok, Lisp_Object predicate, Lisp_Object x)
+ {
+ lisp_h_CHECK_TYPE (ok, predicate, x);
+ }
/* See the macros in intervals.h. */
{
XSTRING (string)->size = newsize;
}
- LISP_INLINE void
- STRING_COPYIN (Lisp_Object string, ptrdiff_t index, char const *new,
- ptrdiff_t count)
- {
- memcpy (SDATA (string) + index, new, count);
- }
- /* Regular vector is just a header plus array of Lisp_Objects. */
-/* Header of vector-like objects. This documents the layout constraints on
- vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
- compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
- and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
- because when two such pointers potentially alias, a compiler won't
- incorrectly reorder loads and stores to their size fields. See
- Bug#8546. */
-struct vectorlike_header
- {
- /* The only field contains various pieces of information:
- - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
- - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
- vector (0) or a pseudovector (1).
- - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
- of slots) of the vector.
- - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
- - a) pseudovector subtype held in PVEC_TYPE_MASK field;
- - b) number of Lisp_Objects slots at the beginning of the object
- held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
- traced by the GC;
- - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
- measured in word_size units. Rest fields may also include
- Lisp_Objects, but these objects usually needs some special treatment
- during GC.
- There are some exceptions. For PVEC_FREE, b) is always zero. For
- PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
- Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
- 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
- ptrdiff_t size;
- };
-
+ /* A regular vector is just a header plus an array of Lisp_Objects. */
struct Lisp_Vector
{
return PSEUDOVECTORP (a, PVEC_FRAME);
}
- LISP_INLINE bool
++INLINE bool
+THREADP (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_THREAD);
+}
+
- LISP_INLINE bool
++INLINE bool
+MUTEXP (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_MUTEX);
+}
+
- LISP_INLINE bool
++INLINE bool
+CONDVARP (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_CONDVAR);
+}
+
/* Test for image (image . spec) */
- LISP_INLINE bool
+ INLINE bool
IMAGEP (Lisp_Object x)
{
return CONSP (x) && EQ (XCAR (x), Qimage);
return extract_float (n);
}
- LISP_INLINE void
+ INLINE void
CHECK_NUMBER_OR_FLOAT (Lisp_Object x)
{
- CHECK_TYPE (FLOATP (x) || INTEGERP (x), Qnumberp, x);
+ CHECK_TYPE (NUMBERP (x), Qnumberp, x);
}
- #define CHECK_NUMBER_OR_FLOAT_COERCE_MARKER(x) \
- do { if (MARKERP (x)) XSETFASTINT (x, marker_position (x)); \
- else CHECK_TYPE (INTEGERP (x) || FLOATP (x), Qnumber_or_marker_p, x); } while (0)
+ #define CHECK_NUMBER_OR_FLOAT_COERCE_MARKER(x) \
+ do { \
+ if (MARKERP (x)) \
+ XSETFASTINT (x, marker_position (x)); \
+ else \
+ CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); \
+ } while (false)
- LISP_INLINE void
+
- LISP_INLINE void
++INLINE void
+CHECK_THREAD (Lisp_Object x)
+{
+ CHECK_TYPE (THREADP (x), Qthreadp, x);
+}
+
- LISP_INLINE void
++INLINE void
+CHECK_MUTEX (Lisp_Object x)
+{
+ CHECK_TYPE (MUTEXP (x), Qmutexp, x);
+}
+
++INLINE void
+CHECK_CONDVAR (Lisp_Object x)
+{
+ CHECK_TYPE (CONDVARP (x), Qcondition_variable_p, 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. */
- LISP_INLINE void
+ INLINE void
CHECK_NUMBER_CAR (Lisp_Object x)
{
Lisp_Object tmp = XCAR (x);
} bt;
};
-extern union specbinding *specpdl;
-extern union specbinding *specpdl_ptr;
-extern ptrdiff_t specpdl_size;
+/* extern union specbinding *specpdl; */
+/* extern union specbinding *specpdl_ptr; */
+/* extern ptrdiff_t specpdl_size; */
- LISP_INLINE ptrdiff_t
+ INLINE ptrdiff_t
SPECPDL_INDEX (void)
{
return specpdl_ptr - specpdl;
state.
Members are volatile if their values need to survive _longjmp when
- a 'struct catchtag' is a local variable. */
- struct catchtag
- {
- Lisp_Object tag;
- Lisp_Object volatile val;
- struct catchtag *volatile next;
- #if 1 /* GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS, but they're defined later. */
- struct gcpro *gcpro;
- #endif
+ a 'struct handler' is a local variable. */
+
+ enum handlertype { CATCHER, CONDITION_CASE };
+
+ struct handler
+ {
+ enum handlertype type;
+ Lisp_Object tag_or_ch;
+ Lisp_Object val;
+ struct handler *next;
+ struct handler *nextfree;
+
+ /* The bytecode interpreter can have several handlers active at the same
+ time, so when we longjmp to one of them, it needs to know which handler
+ this was and what was the corresponding internal state. This is stored
+ here, and when we longjmp we make sure that handlerlist points to the
+ proper handler. */
+ Lisp_Object *bytecode_top;
+ int bytecode_dest;
+
+ /* Most global vars are reset to their value via the specpdl mechanism,
+ but a few others are handled by storing their value here. */
sys_jmp_buf jmp;
- struct handler *f_handlerlist;
- EMACS_INT lisp_eval_depth;
+ EMACS_INT f_lisp_eval_depth;
- ptrdiff_t volatile pdlcount;
+ ptrdiff_t pdlcount;
int poll_suppress_count;
int interrupt_input_blocked;
struct byte_stack *byte_stack;
};
- (c)->lisp_eval_depth = lisp_eval_depth; \
+ /* Fill in the components of c, and put it on the list. */
+ #define PUSH_HANDLER(c, tag_ch_val, handlertype) \
+ if (handlerlist->nextfree) \
+ (c) = handlerlist->nextfree; \
+ else \
+ { \
+ (c) = xmalloc (sizeof (struct handler)); \
+ (c)->nextfree = NULL; \
+ handlerlist->nextfree = (c); \
+ } \
+ (c)->type = (handlertype); \
+ (c)->tag_or_ch = (tag_ch_val); \
+ (c)->val = Qnil; \
+ (c)->next = handlerlist; \
++ (c)->f_lisp_eval_depth = lisp_eval_depth; \
+ (c)->pdlcount = SPECPDL_INDEX (); \
+ (c)->poll_suppress_count = poll_suppress_count; \
+ (c)->interrupt_input_blocked = interrupt_input_blocked;\
+ (c)->byte_stack = byte_stack_list; \
+ handlerlist = (c);
+
+
extern Lisp_Object memory_signal_data;
-/* An address near the bottom of the stack.
- Tells GC how to save a copy of the stack. */
-extern char *stack_bottom;
-
/* Check quit-flag and quit if it is non-nil.
Typing C-g does not directly cause a quit; it only sets Vquit_flag.
So the program needs to do QUIT at times when it is safe to quit.
extern _Noreturn void buffer_memory_full (ptrdiff_t);
extern bool survives_gc_p (Lisp_Object);
extern void mark_object (Lisp_Object);
- #if defined REL_ALLOC && !defined SYSTEM_MALLOC
+ #if defined REL_ALLOC && !defined SYSTEM_MALLOC && !defined HYBRID_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 Lisp_Object *stack_base;
extern EMACS_INT consing_since_gc;
extern EMACS_INT gc_relative_threshold;
extern EMACS_INT memory_full_cons_threshold;
}
/* Defined in eval.c. */
- extern Lisp_Object Qautoload, Qexit, Qinteractive, Qcommandp, Qmacro;
- extern Lisp_Object Qinhibit_quit, Qinternal_interpreter_environment, Qclosure;
- extern Lisp_Object Qand_rest;
-extern EMACS_INT lisp_eval_depth;
extern Lisp_Object Vautoload_queue;
+ extern Lisp_Object Vrun_hooks;
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
-extern struct handler *handlerlist;
+
/* To run a normal hook, use the appropriate function from the list below.
The calling convention:
extern void init_eval (void);
extern void syms_of_eval (void);
extern void unwind_body (Lisp_Object);
- extern void record_in_backtrace (Lisp_Object function,
- Lisp_Object *args, ptrdiff_t nargs);
+ extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t);
-extern void mark_specpdl (void);
+extern void mark_specpdl (union specbinding *first, union specbinding *ptr);
extern void get_backtrace (Lisp_Object array);
Lisp_Object backtrace_top_function (void);
extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
extern bool let_shadows_global_binding_p (Lisp_Object symbol);
+/* Defined in thread.c. */
+extern void mark_threads (void);
+
/* Defined in editfns.c. */
- extern Lisp_Object Qfield;
extern void insert1 (Lisp_Object);
- extern Lisp_Object format2 (const char *, Lisp_Object, Lisp_Object);
extern Lisp_Object save_excursion_save (void);
extern Lisp_Object save_restriction_save (void);
extern void save_excursion_restore (Lisp_Object);
/* Defined in bytecode.c. */
extern void syms_of_bytecode (void);
- #if BYTE_MARK_STACK
- extern void mark_byte_stack (struct byte_stack *);
- #endif
- extern void unmark_byte_stack (struct byte_stack *);
-extern struct byte_stack *byte_stack_list;
-extern void relocate_byte_stack (void);
++extern void relocate_byte_stack (struct byte_stack *);
extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, ptrdiff_t, Lisp_Object *);
print_object (AREF (obj, FONT_NAME_INDEX), printcharfun,
escapeflag);
}
- PRINTCHAR ('>');
+ printchar ('>', printcharfun);
}
- strout ("#<thread ", -1, -1, printcharfun);
+ else if (THREADP (obj))
+ {
- PRINTCHAR ('>');
++ print_c_string ("#<thread ", printcharfun);
+ if (STRINGP (XTHREAD (obj)->name))
+ print_string (XTHREAD (obj)->name, printcharfun);
+ else
+ {
+ int len = sprintf (buf, "%p", XTHREAD (obj));
+ strout (buf, len, len, printcharfun);
+ }
- strout ("#<mutex ", -1, -1, printcharfun);
++ printchar ('>', printcharfun);
+ }
+ else if (MUTEXP (obj))
+ {
- PRINTCHAR ('>');
++ print_c_string ("#<mutex ", printcharfun);
+ if (STRINGP (XMUTEX (obj)->name))
+ print_string (XMUTEX (obj)->name, printcharfun);
+ else
+ {
+ int len = sprintf (buf, "%p", XMUTEX (obj));
+ strout (buf, len, len, printcharfun);
+ }
- strout ("#<condvar ", -1, -1, printcharfun);
++ printchar ('>', printcharfun);
+ }
+ else if (CONDVARP (obj))
+ {
- PRINTCHAR ('>');
++ print_c_string ("#<condvar ", printcharfun);
+ if (STRINGP (XCONDVAR (obj)->name))
+ print_string (XCONDVAR (obj)->name, printcharfun);
+ else
+ {
+ int len = sprintf (buf, "%p", XCONDVAR (obj));
+ strout (buf, len, len, printcharfun);
+ }
++ printchar ('>', printcharfun);
+ }
else
{
ptrdiff_t size = ASIZE (obj);
#endif
#ifdef WINDOWSNT
-extern int sys_select (int, fd_set *, fd_set *, fd_set *,
- struct timespec *, void *);
+#include "w32.h"
#endif
+ /* Work around GCC 4.7.0 bug with strict overflow checking; see
+ <http://gcc.gnu.org/bugzilla/show_bug.cgi?id=52904>.
+ This bug appears to be fixed in GCC 5.1, so don't work around it there. */
+ #if __GNUC__ == 4 && __GNUC_MINOR__ >= 3
+ # pragma GCC diagnostic ignored "-Wstrict-overflow"
+ #endif
+ \f
+ /* True if keyboard input is on hold, zero otherwise. */
+
+ static bool kbd_is_on_hold;
+
+ /* Nonzero means don't run process sentinels. This is used
+ when exiting. */
+ bool inhibit_sentinels;
+
+ #ifdef subprocesses
+
#ifndef SOCK_CLOEXEC
# define SOCK_CLOEXEC 0
#endif
static int num_pending_connects;
#endif /* NON_BLOCKING_CONNECT */
-/* The largest descriptor currently in use for a process object; -1 if none. */
-static int max_process_desc;
-
-/* The largest descriptor currently in use for input; -1 if none. */
-static int max_input_desc;
+/* The largest descriptor currently in use; -1 if none. */
+static int max_desc;
- /* Indexed by descriptor, gives the process (if any) for that descriptor */
- static Lisp_Object chan_process[MAXDESC];
+ /* Indexed by descriptor, gives the process (if any) for that descriptor. */
+ static Lisp_Object chan_process[FD_SETSIZE];
- /* Alist of elements (NAME . PROCESS) */
+ /* Alist of elements (NAME . PROCESS). */
static Lisp_Object Vprocess_alist;
/* Buffered-ahead input char from process, indexed by channel.
{
p->write_queue = val;
}
+ static void
+ pset_stderrproc (struct Lisp_Process *p, Lisp_Object val)
+ {
+ p->stderrproc = val;
+ }
\f
+ static Lisp_Object
+ make_lisp_proc (struct Lisp_Process *p)
+ {
+ return make_lisp_ptr (p, Lisp_Vectorlike);
+ }
+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;
+ /* 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];
+ } fd_callback_info[FD_SETSIZE];
/* Add a file descriptor FD to be monitored for when read is possible.
fd_callback_info[fd].func = func;
fd_callback_info[fd].data = data;
- fd_callback_info[fd].condition |= FOR_READ;
+}
+
+static void
+add_non_keyboard_read_fd (int fd)
+{
- eassert (fd >= 0 && fd < MAXDESC);
++ eassert (fd >= 0 && fd < FD_SETSIZE);
+ eassert (fd_callback_info[fd].func == NULL);
+ fd_callback_info[fd].flags |= FOR_READ;
+ if (fd > max_desc)
+ max_desc = fd;
+}
+
+static 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. */
void
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;
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;
+ if (fd > max_desc)
+ max_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;
}
-/* FD is no longer an input descriptor; update max_input_desc accordingly. */
+static void
+add_non_blocking_write_fd (int fd)
+{
- eassert (fd >= 0 && fd < MAXDESC);
++ eassert (fd >= 0 && fd < FD_SETSIZE);
+ eassert (fd_callback_info[fd].func == NULL);
+
+ fd_callback_info[fd].flags |= FOR_WRITE | NON_BLOCKING_CONNECT_FD;
+ if (fd > max_desc)
+ max_desc = fd;
+#ifdef NON_BLOCKING_CONNECT
+ ++num_pending_connects;
+#endif
+}
static void
-delete_input_desc (int fd)
+recompute_max_desc (void)
{
- if (fd == max_input_desc)
- {
- do
- fd--;
- while (0 <= fd && ! (FD_ISSET (fd, &input_wait_mask)
- || FD_ISSET (fd, &write_mask)));
+ int fd;
- max_input_desc = fd;
+ for (fd = max_desc; fd >= 0; --fd)
+ {
+ if (fd_callback_info[fd].flags != 0)
+ {
+ max_desc = fd;
+ break;
+ }
}
}
void
delete_write_fd (int fd)
{
- FD_CLR (fd, &write_mask);
- fd_callback_info[fd].condition &= ~FOR_WRITE;
- if (fd_callback_info[fd].condition == 0)
+ int lim = max_desc;
+
- eassert (fd < MAXDESC);
-
+#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)
{
fd_callback_info[fd].func = 0;
fd_callback_info[fd].data = 0;
- delete_input_desc (fd);
+
+ if (fd == max_desc)
+ recompute_max_desc ();
+ }
+}
+
+static void
- compute_input_wait_mask (SELECT_TYPE *mask)
++compute_input_wait_mask (fd_set *mask)
+{
+ int fd;
+
+ FD_ZERO (mask);
+ for (fd = 0; fd <= max_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_callback_info[fd].waiting_thread = current_thread;
+ }
+ }
+}
+
+static void
- compute_non_process_wait_mask (SELECT_TYPE *mask)
++compute_non_process_wait_mask (fd_set *mask)
+{
+ int fd;
+
+ FD_ZERO (mask);
+ for (fd = 0; fd <= max_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_callback_info[fd].waiting_thread = current_thread;
+ }
+ }
+}
+
+static void
- compute_non_keyboard_wait_mask (SELECT_TYPE *mask)
++compute_non_keyboard_wait_mask (fd_set *mask)
+{
+ int fd;
+
+ FD_ZERO (mask);
+ for (fd = 0; fd <= max_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_callback_info[fd].waiting_thread = current_thread;
+ }
+ }
+}
+
+static void
- compute_write_mask (SELECT_TYPE *mask)
++compute_write_mask (fd_set *mask)
+{
+ int fd;
+
+ FD_ZERO (mask);
+ for (fd = 0; fd <= max_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_callback_info[fd].waiting_thread = current_thread;
+ }
+ }
+}
+
+static void
+clear_waiting_thread_info (void)
+{
+ int fd;
+
+ for (fd = 0; fd <= max_desc; ++fd)
+ {
+ if (fd_callback_info[fd].waiting_thread == current_thread)
+ fd_callback_info[fd].waiting_thread = NULL;
}
}
p->pty_flag = pty_flag;
pset_status (p, Qrun);
- if (!EQ (p->command, Qt))
- {
- FD_SET (inchannel, &input_wait_mask);
- FD_SET (inchannel, &non_keyboard_wait_mask);
- }
-
- if (inchannel > max_process_desc)
- max_process_desc = inchannel;
+ add_process_read_fd (inchannel);
- /* This may signal an error. */
+ /* This may signal an error. */
setup_process_coding_systems (process);
block_input ();
p->pid = -2;
}
- if (inchannel > max_process_desc)
- max_process_desc = inchannel;
+ DEFUN ("make-pipe-process", Fmake_pipe_process, Smake_pipe_process,
+ 0, MANY, 0,
+ doc: /* Create and return a bidirectional pipe process.
+
+ In Emacs, pipes are represented by process objects, so input and
+ output work as for subprocesses, and `delete-process' closes a pipe.
+ However, a pipe process has no process id, it cannot be signaled,
+ and the status codes are different from normal processes.
+
+ Arguments are specified as keyword/argument pairs. The following
+ arguments are defined:
+
+ :name NAME -- NAME is the name of the process. It is modified if necessary to make it unique.
+
+ :buffer BUFFER -- BUFFER is the buffer (or buffer-name) to associate
+ with the process. Process output goes at the end of that buffer,
+ unless you specify an output stream or filter function to handle the
+ output. If BUFFER is not given, the value of NAME is used.
+
+ :coding CODING -- If CODING is a symbol, it specifies the coding
+ system used for both reading and writing for this process. If CODING
+ is a cons (DECODING . ENCODING), DECODING is used for reading, and
+ ENCODING is used for writing.
+
+ :noquery BOOL -- When exiting Emacs, query the user if BOOL is nil and
+ the process is running. If BOOL is not given, query before exiting.
+
+ :stop BOOL -- Start process in the `stopped' state if BOOL non-nil.
+ In the stopped state, a pipe process does not accept incoming data,
+ but you can send outgoing data. The stopped state is cleared by
+ `continue-process' and set by `stop-process'.
+
+ :filter FILTER -- Install FILTER as the process filter.
+
+ :sentinel SENTINEL -- Install SENTINEL as the process sentinel.
+
+ usage: (make-pipe-process &rest ARGS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+ {
+ Lisp_Object proc, contact;
+ struct Lisp_Process *p;
+ Lisp_Object name, buffer;
+ Lisp_Object tem;
+ ptrdiff_t specpdl_count;
+ int inchannel, outchannel;
+
+ if (nargs == 0)
+ return Qnil;
+
+ contact = Flist (nargs, args);
+
+ name = Fplist_get (contact, QCname);
+ CHECK_STRING (name);
+ proc = make_process (name);
+ specpdl_count = SPECPDL_INDEX ();
+ record_unwind_protect (remove_process, proc);
+ p = XPROCESS (proc);
+
+ if (emacs_pipe (p->open_fd + SUBPROCESS_STDIN) != 0
+ || emacs_pipe (p->open_fd + READ_FROM_SUBPROCESS) != 0)
+ report_file_error ("Creating pipe", Qnil);
+ outchannel = p->open_fd[WRITE_TO_SUBPROCESS];
+ inchannel = p->open_fd[READ_FROM_SUBPROCESS];
+
+ fcntl (inchannel, F_SETFL, O_NONBLOCK);
+ fcntl (outchannel, F_SETFL, O_NONBLOCK);
+
+ #ifdef WINDOWSNT
+ register_aux_fd (inchannel);
+ #endif
+
+ /* Record this as an active process, with its channels. */
+ chan_process[inchannel] = proc;
+ p->infd = inchannel;
+ p->outfd = outchannel;
+
- {
- FD_SET (inchannel, &input_wait_mask);
- FD_SET (inchannel, &non_keyboard_wait_mask);
- }
++ if (inchannel > max_desc)
++ max_desc = inchannel;
+
+ buffer = Fplist_get (contact, QCbuffer);
+ if (NILP (buffer))
+ buffer = name;
+ buffer = Fget_buffer_create (buffer);
+ pset_buffer (p, buffer);
+
+ pset_childp (p, contact);
+ pset_plist (p, Fcopy_sequence (Fplist_get (contact, QCplist)));
+ pset_type (p, Qpipe);
+ pset_sentinel (p, Fplist_get (contact, QCsentinel));
+ pset_filter (p, Fplist_get (contact, QCfilter));
+ pset_log (p, Qnil);
+ if (tem = Fplist_get (contact, QCnoquery), !NILP (tem))
+ p->kill_without_query = 1;
+ if (tem = Fplist_get (contact, QCstop), !NILP (tem))
+ pset_command (p, Qt);
+ eassert (! p->pty_flag);
+
+ if (!EQ (p->command, Qt))
++ add_non_keyboard_read_fd (inchannel);
+ p->adaptive_read_buffering
+ = (NILP (Vprocess_adaptive_read_buffering) ? 0
+ : EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2);
+
+ /* Make the process marker point into the process buffer (if any). */
+ if (BUFFERP (buffer))
+ set_marker_both (p->mark, buffer,
+ BUF_ZV (XBUFFER (buffer)),
+ BUF_ZV_BYTE (XBUFFER (buffer)));
+
+ {
+ /* Setup coding systems for communicating with the network stream. */
+
+ /* Qt denotes we have not yet called Ffind_operation_coding_system. */
+ Lisp_Object coding_systems = Qt;
+ Lisp_Object val;
+
+ tem = Fplist_get (contact, QCcoding);
+ val = Qnil;
+ if (!NILP (tem))
+ {
+ val = tem;
+ if (CONSP (val))
+ val = XCAR (val);
+ }
+ else if (!NILP (Vcoding_system_for_read))
+ val = Vcoding_system_for_read;
+ else if ((!NILP (buffer) && NILP (BVAR (XBUFFER (buffer), enable_multibyte_characters)))
+ || (NILP (buffer) && NILP (BVAR (&buffer_defaults, enable_multibyte_characters))))
+ /* We dare not decode end-of-line format by setting VAL to
+ Qraw_text, because the existing Emacs Lisp libraries
+ assume that they receive bare code including a sequence of
+ CR LF. */
+ val = Qnil;
+ else
+ {
+ if (CONSP (coding_systems))
+ val = XCAR (coding_systems);
+ else if (CONSP (Vdefault_process_coding_system))
+ val = XCAR (Vdefault_process_coding_system);
+ else
+ val = Qnil;
+ }
+ pset_decode_coding_system (p, val);
+
+ if (!NILP (tem))
+ {
+ val = tem;
+ if (CONSP (val))
+ val = XCDR (val);
+ }
+ else if (!NILP (Vcoding_system_for_write))
+ val = Vcoding_system_for_write;
+ else if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
+ val = Qnil;
+ else
+ {
+ if (CONSP (coding_systems))
+ val = XCDR (coding_systems);
+ else if (CONSP (Vdefault_process_coding_system))
+ val = XCDR (Vdefault_process_coding_system);
+ else
+ val = Qnil;
+ }
+ pset_encode_coding_system (p, val);
+ }
+ /* This may signal an error. */
+ setup_process_coding_systems (proc);
+
+ specpdl_ptr = specpdl + specpdl_count;
+
+ return proc;
+ }
+
\f
/* Convert an internal struct sockaddr to a lisp object (vector or string).
The address family of sa is not included in the result. */
p->inherit_coding_system_flag
= (NILP (buffer) ? 0 : ps->inherit_coding_system_flag);
+ AUTO_STRING (dash, "-");
+ AUTO_STRING (nl, "\n");
+ Lisp_Object host_string = STRINGP (host) ? host : dash;
+
if (!NILP (ps->log))
- call3 (ps->log, server, proc,
- concat3 (build_string ("accept from "),
- (STRINGP (host) ? host : build_string ("-")),
- build_string ("\n")));
+ {
+ AUTO_STRING (accept_from, "accept from ");
+ call3 (ps->log, server, proc, concat3 (accept_from, host_string, nl));
+ }
- exec_sentinel (proc,
- concat3 (build_string ("open from "),
- (STRINGP (host) ? host : build_string ("-")),
- build_string ("\n")));
+ AUTO_STRING (open_from, "open from ");
+ exec_sentinel (proc, concat3 (open_from, host_string, nl));
}
-/* This variable is different from waiting_for_input in keyboard.c.
- It is used to communicate to a lisp process-filter/sentinel (via the
- function Fwaiting_for_user_input_p below) whether Emacs was waiting
- for user-input when that process-filter was called.
- waiting_for_input cannot be used as that is by definition 0 when
- lisp code is being evalled.
- This is also used in record_asynch_buffer_change.
- For that purpose, this must be 0
- when not inside wait_reading_process_output. */
-static int waiting_for_user_input_p;
-
static void
wait_reading_process_output_unwind (int data)
{
bool no_avail;
int xerrno;
Lisp_Object proc;
- EMACS_TIME timeout, end_time;
- int wait_channel = -1;
- bool got_some_input = 0;
+ struct timespec timeout, end_time, timer_delay;
+ struct timespec got_output_end_time = invalid_timespec ();
+ enum { MINIMUM = -1, TIMEOUT, INFINITY } wait;
+ int got_some_output = -1;
ptrdiff_t count = SPECPDL_INDEX ();
+ /* Close to the current time if known, an invalid timespec otherwise. */
+ struct timespec now = invalid_timespec ();
+
+ eassert (wait_proc == NULL
+ || EQ (wait_proc->thread, Qnil)
+ || XTHREAD (wait_proc->thread) == current_thread);
+
FD_ZERO (&Available);
FD_ZERO (&Writeok);
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);
+ timeout = make_timespec (0, 0);
- if ((pselect (max (max_process_desc, max_input_desc) + 1,
- &Atemp,
+ if ((thread_select (pselect, max_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
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
- check_write = 1;
- #endif
- check_delay = wait_channel >= 0 ? 0 : process_output_delay_count;
+ check_delay = wait_proc ? 0 : process_output_delay_count;
+ check_write = true;
}
/* If frame size has changed or the window is newly mapped,
Vprocess_adaptive_read_buffering is nil. */
if (process_output_skip && check_delay > 0)
{
- int nsecs = EMACS_NSECS (timeout);
- if (EMACS_SECS (timeout) > 0 || nsecs > READ_OUTPUT_DELAY_MAX)
- nsecs = READ_OUTPUT_DELAY_MAX;
+ int adaptive_nsecs = timeout.tv_nsec;
+ if (timeout.tv_sec > 0 || adaptive_nsecs > READ_OUTPUT_DELAY_MAX)
+ adaptive_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))
if (!XPROCESS (proc)->read_output_skip)
continue;
FD_CLR (channel, &Available);
+ process_skipped = true;
XPROCESS (proc)->read_output_skip = 0;
- if (XPROCESS (proc)->read_output_delay < nsecs)
- nsecs = XPROCESS (proc)->read_output_delay;
+ if (XPROCESS (proc)->read_output_delay < adaptive_nsecs)
+ adaptive_nsecs = XPROCESS (proc)->read_output_delay;
}
}
- timeout = make_emacs_time (0, nsecs);
+ timeout = make_timespec (0, adaptive_nsecs);
process_output_skip = 0;
}
- #endif
+
+ /* If we've got some output and haven't limited our timeout
+ with adaptive read buffering, limit it. */
+ if (got_some_output > 0 && !process_skipped
+ && (timeout.tv_sec
+ || timeout.tv_nsec > READ_OUTPUT_DELAY_INCREMENT))
+ timeout = make_timespec (0, READ_OUTPUT_DELAY_INCREMENT);
+
+
+ if (NILP (wait_for_cell) && just_wait_proc >= 0
+ && timespec_valid_p (timer_delay)
+ && timespec_cmp (timer_delay, timeout) < 0)
+ {
+ if (!timespec_valid_p (now))
+ now = current_timespec ();
+ struct timespec timeout_abs = timespec_add (now, timeout);
+ if (!timespec_valid_p (got_output_end_time)
+ || timespec_cmp (timeout_abs, got_output_end_time) < 0)
+ got_output_end_time = timeout_abs;
+ timeout = timer_delay;
+ }
+ else
+ got_output_end_time = invalid_timespec ();
+
+ /* NOW can become inaccurate if time can pass during pselect. */
+ if (timeout.tv_sec > 0 || timeout.tv_nsec > 0)
+ now = invalid_timespec ();
+
+ nfds = thread_select (
#if defined (HAVE_NS)
- nfds = ns_select
+ ns_select
#elif defined (HAVE_GLIB)
- nfds = xg_select
+ xg_select
#else
- nfds = pselect
+ pselect
#endif
- (max (max_process_desc, max_input_desc) + 1,
- &Available,
- (check_write ? &Writeok : 0),
- NULL, &timeout, NULL);
+ , max_desc + 1,
+ &Available,
+ (check_write ? &Writeok : 0),
+ NULL, &timeout, NULL);
#ifdef HAVE_GNUTLS
/* GnuTLS buffers data internally. In lowat mode it leaves
status_notify to do it later, it will read input
from the process before calling the sentinel. */
exec_sentinel (proc, build_string ("open\n"));
- if (!EQ (p->filter, Qt) && !EQ (p->command, Qt))
+ if (0 <= p->infd && !EQ (p->filter, Qt)
+ && !EQ (p->command, Qt))
- {
- FD_SET (p->infd, &input_wait_mask);
- FD_SET (p->infd, &non_keyboard_wait_mask);
- }
+ delete_read_fd (p->infd);
}
}
#endif /* NON_BLOCKING_CONNECT */
/* The following functions are needed even if async subprocesses are
not supported. Some of them are no-op stubs in that case. */
- FD_SET (fd, &input_wait_mask);
- FD_SET (fd, &non_keyboard_wait_mask);
- FD_SET (fd, &non_process_wait_mask);
- fd_callback_info[fd].func = timerfd_callback;
- fd_callback_info[fd].data = NULL;
- fd_callback_info[fd].condition |= FOR_READ;
- if (fd > max_input_desc)
- max_input_desc = fd;
+ #ifdef HAVE_TIMERFD
+
+ /* Add FD, which is a descriptor returned by timerfd_create,
+ to the set of non-keyboard input descriptors. */
+
+ void
+ add_timer_wait_descriptor (int fd)
+ {
++ add_read_fd (fd, timerfd_callback, NULL);
++ if (fd > max_desc)
++ max_desc = fd;
+ }
+
+ #endif /* HAVE_TIMERFD */
+
/* Add DESC to the set of keyboard input descriptors. */
void
add_keyboard_wait_descriptor (int desc)
{
- #ifdef subprocesses /* actually means "not MSDOS" */
- eassert (desc >= 0 && desc < MAXDESC);
+ #ifdef subprocesses /* Actually means "not MSDOS". */
- FD_SET (desc, &input_wait_mask);
- FD_SET (desc, &non_process_wait_mask);
- if (desc > max_input_desc)
- max_input_desc = desc;
++ eassert (desc >= 0 && desc < FD_SETSIZE);
+ fd_callback_info[desc].flags |= FOR_READ | KEYBOARD_FD;
+ if (desc > max_desc)
+ max_desc = desc;
#endif
}
delete_keyboard_wait_descriptor (int desc)
{
#ifdef subprocesses
- FD_CLR (desc, &input_wait_mask);
- FD_CLR (desc, &non_process_wait_mask);
- delete_input_desc (desc);
+ int fd;
+ int lim = max_desc;
+
- eassert (desc >= 0 && desc < MAXDESC);
++ eassert (desc >= 0 && desc < FD_SETSIZE);
+
+ fd_callback_info[desc].flags &= ~(FOR_READ | KEYBOARD_FD | PROCESS_FD);
+
+ if (desc == max_desc)
+ recompute_max_desc ();
#endif
}
Lisp_Object gnutls_cred_type;
#endif
+ /* Pipe process attached to the standard error of this process. */
+ Lisp_Object stderrproc;
+
+ /* 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. */
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);
- #ifdef NS_IMPL_GNUSTEP
extern void catch_child_signal (void);
+
+ #ifdef WINDOWSNT
+ extern Lisp_Object network_interface_list (void);
+ extern Lisp_Object network_interface_info (Lisp_Object);
#endif
+ extern Lisp_Object remove_slash_colon (Lisp_Object);
+
+extern void update_processes_for_thread_death (Lisp_Object);
+
INLINE_HEADER_END
+
+ #endif /* EMACS_PROCESS_H */
}
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;
+ static const_re_char *whitespace_regexp;
+#endif
void
re_set_whitespace_regexp (const char *regexp)
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
+ # include "lisp.h"
/* 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
+ /* Roughly the maximum number of failure points on the stack. */
+ extern size_t re_max_failures;
+
\f
/* Define combinations of the above bits for the standard possibilities.
(The [[[ comments delimit what gets put into the Texinfo file, so
/* 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;
-
- /* Error condition used for failing searches. */
- static Lisp_Object Qsearch_failed;
-
static void set_search_regs (ptrdiff_t, ptrdiff_t);
static void save_search_regs (void);
static EMACS_INT simple_search (EMACS_INT, unsigned char *, ptrdiff_t,
#include <sys/select.h>
#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
+ #include "lisp.h"
+
- EMACS_TIME *, sigset_t *);
+#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 */
+
#ifdef FD_SET
- #ifdef FD_SETSIZE
- #define MAXDESC FD_SETSIZE
- #else
- #define MAXDESC 64
+ #ifndef FD_SETSIZE
+ #define FD_SETSIZE 64
#endif
- #define SELECT_TYPE fd_set
#else /* no FD_SET */
- #define MAXDESC 32
- #define SELECT_TYPE int
+ #define FD_SETSIZE 32
+ typedef int fd_set;
/* Define the macros to access a single-int bitmap of descriptors. */
#define FD_SET(n, p) (*(p) |= (1 << (n)))
--- /dev/null
- Lisp_Object Qthreadp, Qmutexp, Qcondition_variable_p;
+/* Threading code.
+ Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+
+#include <config.h>
+#include <setjmp.h>
+#include "lisp.h"
+#include "character.h"
+#include "buffer.h"
+#include "process.h"
+#include "coding.h"
+
+static struct thread_state primary_thread;
+
+struct thread_state *current_thread = &primary_thread;
+
+static struct thread_state *all_threads = &primary_thread;
+
+static sys_mutex_t global_lock;
+
- If this thread does not own MUTEX, signal an error.
++extern int poll_suppress_count;
++extern volatile int interrupt_input_blocked;
+
+\f
+
+/* m_specpdl is set when the thread is created and cleared when the
+ thread dies. */
+#define thread_alive_p(STATE) ((STATE)->m_specpdl != NULL)
+
+\f
+
+static void
+release_global_lock (void)
+{
+ sys_mutex_unlock (&global_lock);
+}
+
+/* You must call this after acquiring the global lock.
+ acquire_global_lock does it for you. */
+static void
+post_acquire_global_lock (struct thread_state *self)
+{
+ Lisp_Object buffer;
+ struct thread_state *prev_thread = current_thread;
+
+ /* Do this early on, so that code below could signal errors (e.g.,
+ unbind_for_thread_switch might) correctly, because we are already
+ running in the context of the thread pointed by SELF. */
+ current_thread = self;
+
+ if (prev_thread != current_thread)
+ {
+ /* PREV_THREAD is NULL if the previously current thread
+ exited. In this case, there is no reason to unbind, and
+ trying will crash. */
+ if (prev_thread != NULL)
+ unbind_for_thread_switch (prev_thread);
+ rebind_for_thread_switch ();
+ }
+
+ /* We need special handling to re-set the buffer. */
+ XSETBUFFER (buffer, self->m_current_buffer);
+ self->m_current_buffer = 0;
+ set_buffer_internal (XBUFFER (buffer));
+
+ if (!NILP (current_thread->error_symbol))
+ {
+ Lisp_Object sym = current_thread->error_symbol;
+ Lisp_Object data = current_thread->error_data;
+
+ current_thread->error_symbol = Qnil;
+ current_thread->error_data = Qnil;
+ Fsignal (sym, data);
+ }
+}
+
+static void
+acquire_global_lock (struct thread_state *self)
+{
+ sys_mutex_lock (&global_lock);
+ post_acquire_global_lock (self);
+}
+
+\f
+
+static void
+lisp_mutex_init (lisp_mutex_t *mutex)
+{
+ mutex->owner = NULL;
+ mutex->count = 0;
+ sys_cond_init (&mutex->condition);
+}
+
+static int
+lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
+{
+ struct thread_state *self;
+
+ if (mutex->owner == NULL)
+ {
+ mutex->owner = current_thread;
+ mutex->count = new_count == 0 ? 1 : new_count;
+ return 0;
+ }
+ if (mutex->owner == current_thread)
+ {
+ eassert (new_count == 0);
+ ++mutex->count;
+ return 0;
+ }
+
+ self = current_thread;
+ self->wait_condvar = &mutex->condition;
+ while (mutex->owner != NULL && (new_count != 0
+ || NILP (self->error_symbol)))
+ sys_cond_wait (&mutex->condition, &global_lock);
+ self->wait_condvar = NULL;
+
+ if (new_count == 0 && !NILP (self->error_symbol))
+ return 1;
+
+ mutex->owner = self;
+ mutex->count = new_count == 0 ? 1 : new_count;
+
+ return 1;
+}
+
+static int
+lisp_mutex_unlock (lisp_mutex_t *mutex)
+{
+ struct thread_state *self = current_thread;
+
+ if (mutex->owner != current_thread)
+ error ("blah");
+
+ if (--mutex->count > 0)
+ return 0;
+
+ mutex->owner = NULL;
+ sys_cond_broadcast (&mutex->condition);
+
+ return 1;
+}
+
+static unsigned int
+lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex)
+{
+ struct thread_state *self = current_thread;
+ unsigned int result = mutex->count;
+
+ /* Ensured by condvar code. */
+ eassert (mutex->owner == current_thread);
+
+ mutex->count = 0;
+ mutex->owner = NULL;
+ sys_cond_broadcast (&mutex->condition);
+
+ return result;
+}
+
+static void
+lisp_mutex_destroy (lisp_mutex_t *mutex)
+{
+ sys_cond_destroy (&mutex->condition);
+}
+
+static int
+lisp_mutex_owned_p (lisp_mutex_t *mutex)
+{
+ return mutex->owner == current_thread;
+}
+
+\f
+
+DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0,
+ doc: /* Create a mutex.
+A mutex provides a synchronization point for threads.
+Only one thread at a time can hold a mutex. Other threads attempting
+to acquire it will block until the mutex is available.
+
+A thread can acquire a mutex any number of times.
+
+NAME, if given, is used as the name of the mutex. The name is
+informational only. */)
+ (Lisp_Object name)
+{
+ struct Lisp_Mutex *mutex;
+ Lisp_Object result;
+
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
+ memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
+ 0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
+ mutex));
+ mutex->name = name;
+ lisp_mutex_init (&mutex->mutex);
+
+ XSETMUTEX (result, mutex);
+ return result;
+}
+
+static void
+mutex_lock_callback (void *arg)
+{
+ struct Lisp_Mutex *mutex = arg;
+ struct thread_state *self = current_thread;
+
+ if (lisp_mutex_lock (&mutex->mutex, 0))
+ post_acquire_global_lock (self);
+}
+
+static void
+do_unwind_mutex_lock (void)
+{
+ current_thread->event_object = Qnil;
+}
+
+DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
+ doc: /* Acquire a mutex.
+If the current thread already owns MUTEX, increment the count and
+return.
+Otherwise, if no thread owns MUTEX, make the current thread own it.
+Otherwise, block until MUTEX is available, or until the current thread
+is signalled using `thread-signal'.
+Note that calls to `mutex-lock' and `mutex-unlock' must be paired. */)
+ (Lisp_Object mutex)
+{
+ struct Lisp_Mutex *lmutex;
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ current_thread->event_object = mutex;
+ record_unwind_protect_void (do_unwind_mutex_lock);
+ flush_stack_call_func (mutex_lock_callback, lmutex);
+ return unbind_to (count, Qnil);
+}
+
+static void
+mutex_unlock_callback (void *arg)
+{
+ struct Lisp_Mutex *mutex = arg;
+ struct thread_state *self = current_thread;
+
+ if (lisp_mutex_unlock (&mutex->mutex))
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
+ doc: /* Release the mutex.
- SELECT_TYPE *rfds;
- SELECT_TYPE *wfds;
- SELECT_TYPE *efds;
- EMACS_TIME *timeout;
++If this thread does not own MUTEX, signal an error.
+Otherwise, decrement the mutex's count. If the count is zero,
+release MUTEX. */)
+ (Lisp_Object mutex)
+{
+ struct Lisp_Mutex *lmutex;
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ flush_stack_call_func (mutex_unlock_callback, lmutex);
+ return Qnil;
+}
+
+DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0,
+ doc: /* Return the name of MUTEX.
+If no name was given when MUTEX was created, return nil. */)
+ (Lisp_Object mutex)
+{
+ struct Lisp_Mutex *lmutex;
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ return lmutex->name;
+}
+
+void
+finalize_one_mutex (struct Lisp_Mutex *mutex)
+{
+ lisp_mutex_destroy (&mutex->mutex);
+}
+
+\f
+
+DEFUN ("make-condition-variable",
+ Fmake_condition_variable, Smake_condition_variable,
+ 1, 2, 0,
+ doc: /* Make a condition variable.
+A condition variable provides a way for a thread to sleep while
+waiting for a state change.
+
+MUTEX is the mutex associated with this condition variable.
+NAME, if given, is the name of this condition variable. The name is
+informational only. */)
+ (Lisp_Object mutex, Lisp_Object name)
+{
+ struct Lisp_CondVar *condvar;
+ Lisp_Object result;
+
+ CHECK_MUTEX (mutex);
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR);
+ memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond),
+ 0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar,
+ cond));
+ condvar->mutex = mutex;
+ condvar->name = name;
+ sys_cond_init (&condvar->cond);
+
+ XSETCONDVAR (result, condvar);
+ return result;
+}
+
+static void
+condition_wait_callback (void *arg)
+{
+ struct Lisp_CondVar *cvar = arg;
+ struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex);
+ struct thread_state *self = current_thread;
+ unsigned int saved_count;
+ Lisp_Object cond;
+
+ XSETCONDVAR (cond, cvar);
+ self->event_object = cond;
+ saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
+ /* If we were signalled while unlocking, we skip the wait, but we
+ still must reacquire our lock. */
+ if (NILP (self->error_symbol))
+ {
+ self->wait_condvar = &cvar->cond;
+ sys_cond_wait (&cvar->cond, &global_lock);
+ self->wait_condvar = NULL;
+ }
+ lisp_mutex_lock (&mutex->mutex, saved_count);
+ self->event_object = Qnil;
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0,
+ doc: /* Wait for the condition variable to be notified.
+CONDITION is the condition variable to wait on.
+
+The mutex associated with CONDITION must be held when this is called.
+It is an error if it is not held.
+
+This releases the mutex and waits for CONDITION to be notified or for
+this thread to be signalled with `thread-signal'. When
+`condition-wait' returns, the mutex will again be locked by this
+thread. */)
+ (Lisp_Object condition)
+{
+ struct Lisp_CondVar *cvar;
+ struct Lisp_Mutex *mutex;
+
+ CHECK_CONDVAR (condition);
+ cvar = XCONDVAR (condition);
+
+ mutex = XMUTEX (cvar->mutex);
+ if (!lisp_mutex_owned_p (&mutex->mutex))
+ error ("fixme");
+
+ flush_stack_call_func (condition_wait_callback, cvar);
+
+ return Qnil;
+}
+
+/* Used to communicate argumnets to condition_notify_callback. */
+struct notify_args
+{
+ struct Lisp_CondVar *cvar;
+ int all;
+};
+
+static void
+condition_notify_callback (void *arg)
+{
+ struct notify_args *na = arg;
+ struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex);
+ struct thread_state *self = current_thread;
+ unsigned int saved_count;
+ Lisp_Object cond;
+
+ XSETCONDVAR (cond, na->cvar);
+ saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
+ if (na->all)
+ sys_cond_broadcast (&na->cvar->cond);
+ else
+ sys_cond_signal (&na->cvar->cond);
+ lisp_mutex_lock (&mutex->mutex, saved_count);
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0,
+ doc: /* Notify a condition variable.
+This wakes a thread waiting on CONDITION.
+If ALL is non-nil, all waiting threads are awoken.
+
+The mutex associated with CONDITION must be held when this is called.
+It is an error if it is not held.
+
+This releases the mutex when notifying CONDITION. When
+`condition-notify' returns, the mutex will again be locked by this
+thread. */)
+ (Lisp_Object condition, Lisp_Object all)
+{
+ struct Lisp_CondVar *cvar;
+ struct Lisp_Mutex *mutex;
+ struct notify_args args;
+
+ CHECK_CONDVAR (condition);
+ cvar = XCONDVAR (condition);
+
+ mutex = XMUTEX (cvar->mutex);
+ if (!lisp_mutex_owned_p (&mutex->mutex))
+ error ("fixme");
+
+ args.cvar = cvar;
+ args.all = !NILP (all);
+ flush_stack_call_func (condition_notify_callback, &args);
+
+ return Qnil;
+}
+
+DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0,
+ doc: /* Return the mutex associated with CONDITION. */)
+ (Lisp_Object condition)
+{
+ struct Lisp_CondVar *cvar;
+
+ CHECK_CONDVAR (condition);
+ cvar = XCONDVAR (condition);
+
+ return cvar->mutex;
+}
+
+DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0,
+ doc: /* Return the name of CONDITION.
+If no name was given when CONDITION was created, return nil. */)
+ (Lisp_Object condition)
+{
+ struct Lisp_CondVar *cvar;
+
+ CHECK_CONDVAR (condition);
+ cvar = XCONDVAR (condition);
+
+ return cvar->name;
+}
+
+void
+finalize_one_condvar (struct Lisp_CondVar *condvar)
+{
+ sys_cond_destroy (&condvar->cond);
+}
+
+\f
+
+struct select_args
+{
+ select_func *func;
+ int max_fds;
- thread_select (select_func *func, int max_fds, SELECT_TYPE *rfds,
- SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *timeout,
++ fd_set *rfds;
++ fd_set *wfds;
++ fd_set *efds;
++ struct timespec *timeout;
+ sigset_t *sigmask;
+ int result;
+};
+
+static void
+really_call_select (void *arg)
+{
+ struct select_args *sa = arg;
+ struct thread_state *self = current_thread;
+
+ release_global_lock ();
+ sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds,
+ sa->timeout, sa->sigmask);
+ acquire_global_lock (self);
+}
+
+int
- #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
- || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
++thread_select (select_func *func, int max_fds, fd_set *rfds,
++ fd_set *wfds, fd_set *efds, struct timespec *timeout,
+ sigset_t *sigmask)
+{
+ struct select_args sa;
+
+ sa.func = func;
+ sa.max_fds = max_fds;
+ sa.rfds = rfds;
+ sa.wfds = wfds;
+ sa.efds = efds;
+ sa.timeout = timeout;
+ sa.sigmask = sigmask;
+ flush_stack_call_func (really_call_select, &sa);
+ return sa.result;
+}
+
+\f
+
+static void
+mark_one_thread (struct thread_state *thread)
+{
+ struct handler *handler;
+ Lisp_Object tem;
+
+ mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
+
- #else
- {
- 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);
+ mark_stack (thread->m_stack_bottom, thread->stack_top);
- mark_object (handler->handler);
- mark_object (handler->var);
+
+ for (handler = thread->m_handlerlist; handler; handler = handler->next)
+ {
- #endif
++ mark_object (handler->tag_or_ch);
++ mark_object (handler->val);
+ }
- unmark_byte_stack (iter->m_byte_stack_list);
+
+ if (thread->m_current_buffer)
+ {
+ XSETBUFFER (tem, thread->m_current_buffer);
+ mark_object (tem);
+ }
+
+ mark_object (thread->m_last_thing_searched);
+
+ if (thread->m_saved_last_thing_searched)
+ mark_object (thread->m_saved_last_thing_searched);
+}
+
+static void
+mark_threads_callback (void *ignore)
+{
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ Lisp_Object thread_obj;
+
+ XSETTHREAD (thread_obj, iter);
+ mark_object (thread_obj);
+ mark_one_thread (iter);
+ }
+}
+
+void
+mark_threads (void)
+{
+ flush_stack_call_func (mark_threads_callback, NULL);
+}
+
+void
+unmark_threads (void)
+{
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ if (iter->m_byte_stack_list)
- new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_gcprolist,
++ relocate_byte_stack (iter->m_byte_stack_list);
+}
+
+\f
+
+static void
+yield_callback (void *ignore)
+{
+ struct thread_state *self = current_thread;
+
+ release_global_lock ();
+ sys_thread_yield ();
+ acquire_global_lock (self);
+}
+
+DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
+ doc: /* Yield the CPU to another thread. */)
+ (void)
+{
+ flush_stack_call_func (yield_callback, NULL);
+ return Qnil;
+}
+
+static Lisp_Object
+invoke_thread_function (void)
+{
+ Lisp_Object iter;
+ volatile struct thread_state *self = current_thread;
+
+ int count = SPECPDL_INDEX ();
+
+ Ffuncall (1, ¤t_thread->function);
+ return unbind_to (count, Qnil);
+}
+
+static Lisp_Object
+do_nothing (Lisp_Object whatever)
+{
+ return whatever;
+}
+
+static void *
+run_thread (void *state)
+{
+ char stack_pos;
+ struct thread_state *self = state;
+ struct thread_state **iter;
+
+ self->m_stack_bottom = &stack_pos;
+ self->stack_top = &stack_pos;
+ self->thread_id = sys_thread_self ();
+
+ acquire_global_lock (self);
+
++ { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
++ This is important since handlerlist->nextfree holds the freelist
++ which would otherwise leak every time we unwind back to top-level. */
++ struct handler *c;
++ handlerlist_sentinel = xzalloc (sizeof (struct handler));
++ handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
++ PUSH_HANDLER (c, Qunbound, CATCHER);
++ eassert (c == handlerlist_sentinel);
++ handlerlist_sentinel->nextfree = NULL;
++ handlerlist_sentinel->next = NULL;
++ }
++
+ /* It might be nice to do something with errors here. */
+ internal_condition_case (invoke_thread_function, Qt, do_nothing);
+
+ update_processes_for_thread_death (Fcurrent_thread ());
+
+ xfree (self->m_specpdl - 1);
+ self->m_specpdl = NULL;
+ self->m_specpdl_ptr = NULL;
+ self->m_specpdl_size = 0;
+
++ {
++ struct handler *c, *c_next;
++ for (c = handlerlist_sentinel; c; c = c_next)
++ {
++ c_next = c->nextfree;
++ xfree (c);
++ }
++ }
++
+ current_thread = NULL;
+ sys_cond_broadcast (&self->thread_condvar);
+
+ /* Unlink this thread from the list of all threads. Note that we
+ have to do this very late, after broadcasting our death.
+ Otherwise the GC may decide to reap the thread_state object,
+ leading to crashes. */
+ for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
+ ;
+ *iter = (*iter)->next_thread;
+
+ release_global_lock ();
+
+ return NULL;
+}
+
+void
+finalize_one_thread (struct thread_state *state)
+{
+ sys_cond_destroy (&state->thread_condvar);
+}
+
+DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
+ doc: /* Start a new thread and run FUNCTION in it.
+When the function exits, the thread dies.
+If NAME is given, it names the new thread. */)
+ (Lisp_Object function, Lisp_Object name)
+{
+ sys_thread_t thr;
+ struct thread_state *new_thread;
+ Lisp_Object result;
+ const char *c_name = NULL;
++ size_t offset = offsetof (struct thread_state, m_byte_stack_list);
+
+ /* Can't start a thread in temacs. */
+ if (!initialized)
+ abort ();
+
+ if (!NILP (name))
+ CHECK_STRING (name);
+
- memset ((char *) new_thread + offsetof (struct thread_state, m_gcprolist),
- 0, sizeof (struct thread_state) - offsetof (struct thread_state,
- m_gcprolist));
++ new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_byte_stack_list,
+ PVEC_THREAD);
- = PSEUDOVECSIZE (struct thread_state, m_gcprolist);
++ memset ((char *) new_thread + offset, 0,
++ sizeof (struct thread_state) - offset);
+
+ new_thread->function = function;
+ new_thread->name = name;
+ new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
+ new_thread->m_saved_last_thing_searched = Qnil;
+ new_thread->m_current_buffer = current_thread->m_current_buffer;
+ new_thread->error_symbol = Qnil;
+ new_thread->error_data = Qnil;
+ new_thread->event_object = Qnil;
+
+ new_thread->m_specpdl_size = 50;
+ new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
+ * sizeof (union specbinding));
+ /* Skip the dummy entry. */
+ ++new_thread->m_specpdl;
+ new_thread->m_specpdl_ptr = new_thread->m_specpdl;
+
+ sys_cond_init (&new_thread->thread_condvar);
+
+ /* We'll need locking here eventually. */
+ new_thread->next_thread = all_threads;
+ all_threads = new_thread;
+
+ if (!NILP (name))
+ c_name = SSDATA (ENCODE_UTF_8 (name));
+
+ if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
+ {
+ /* Restore the previous situation. */
+ all_threads = all_threads->next_thread;
+ error ("Could not start a new thread");
+ }
+
+ /* FIXME: race here where new thread might not be filled in? */
+ XSETTHREAD (result, new_thread);
+ return result;
+}
+
+DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
+ doc: /* Return the current thread. */)
+ (void)
+{
+ Lisp_Object result;
+ XSETTHREAD (result, current_thread);
+ return result;
+}
+
+DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
+ doc: /* Return the name of the THREAD.
+The name is the same object that was passed to `make-thread'. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return tstate->name;
+}
+
+static void
+thread_signal_callback (void *arg)
+{
+ struct thread_state *tstate = arg;
+ struct thread_state *self = current_thread;
+
+ sys_cond_broadcast (tstate->wait_condvar);
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
+ doc: /* Signal an error in a thread.
+This acts like `signal', but arranges for the signal to be raised
+in THREAD. If THREAD is the current thread, acts just like `signal'.
+This will interrupt a blocked call to `mutex-lock', `condition-wait',
+or `thread-join' in the target thread. */)
+ (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ if (tstate == current_thread)
+ Fsignal (error_symbol, data);
+
+ /* What to do if thread is already signalled? */
+ /* What if error_symbol is Qnil? */
+ tstate->error_symbol = error_symbol;
+ tstate->error_data = data;
+
+ if (tstate->wait_condvar)
+ flush_stack_call_func (thread_signal_callback, tstate);
+
+ return Qnil;
+}
+
+DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
+ doc: /* Return t if THREAD is alive, or nil if it has exited. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return thread_alive_p (tstate) ? Qt : Qnil;
+}
+
+DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
+ doc: /* Return the object that THREAD is blocking on.
+If THREAD is blocked in `thread-join' on a second thread, return that
+thread.
+If THREAD is blocked in `mutex-lock', return the mutex.
+If THREAD is blocked in `condition-wait', return the condition variable.
+Otherwise, if THREAD is not blocked, return nil. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return tstate->event_object;
+}
+
+static void
+thread_join_callback (void *arg)
+{
+ struct thread_state *tstate = arg;
+ struct thread_state *self = current_thread;
+ Lisp_Object thread;
+
+ XSETTHREAD (thread, tstate);
+ self->event_object = thread;
+ self->wait_condvar = &tstate->thread_condvar;
+ while (thread_alive_p (tstate) && NILP (self->error_symbol))
+ sys_cond_wait (self->wait_condvar, &global_lock);
+
+ self->wait_condvar = NULL;
+ self->event_object = Qnil;
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
+ doc: /* Wait for a thread to exit.
+This blocks the current thread until THREAD exits.
+It is an error for a thread to try to join itself. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ if (tstate == current_thread)
+ error ("cannot join current thread");
+
+ if (thread_alive_p (tstate))
+ flush_stack_call_func (thread_join_callback, tstate);
+
+ return Qnil;
+}
+
+DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
+ doc: /* Return a list of all threads. */)
+ (void)
+{
+ Lisp_Object result = Qnil;
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ if (thread_alive_p (iter))
+ {
+ Lisp_Object thread;
+
+ XSETTHREAD (thread, iter);
+ result = Fcons (thread, result);
+ }
+ }
+
+ return result;
+}
+
+\f
+
+bool
+thread_check_current_buffer (struct buffer *buffer)
+{
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ if (iter == current_thread)
+ continue;
+
+ if (iter->m_current_buffer == buffer)
+ return true;
+ }
+
+ return false;
+}
+
+\f
+
+static void
+init_primary_thread (void)
+{
+ primary_thread.header.size
- Qthreadp = intern_c_string ("threadp");
- staticpro (&Qthreadp);
- Qmutexp = intern_c_string ("mutexp");
- staticpro (&Qmutexp);
- Qcondition_variable_p = intern_c_string ("condition-variable-p");
- staticpro (&Qcondition_variable_p);
++ = PSEUDOVECSIZE (struct thread_state, m_byte_stack_list);
+ XSETPVECTYPE (&primary_thread, PVEC_THREAD);
+ primary_thread.m_last_thing_searched = Qnil;
+ primary_thread.m_saved_last_thing_searched = Qnil;
+ primary_thread.name = Qnil;
+ primary_thread.function = Qnil;
+ primary_thread.error_symbol = Qnil;
+ primary_thread.error_data = Qnil;
+ primary_thread.event_object = Qnil;
+}
+
+void
+init_threads_once (void)
+{
+ init_primary_thread ();
+}
+
+void
+init_threads (void)
+{
+ init_primary_thread ();
+ sys_cond_init (&primary_thread.thread_condvar);
+ sys_mutex_init (&global_lock);
+ sys_mutex_lock (&global_lock);
+ current_thread = &primary_thread;
+ primary_thread.thread_id = sys_thread_self ();
+}
+
+void
+syms_of_threads (void)
+{
+#ifndef THREADS_ENABLED
+ if (0)
+#endif
+ {
+ defsubr (&Sthread_yield);
+ defsubr (&Smake_thread);
+ defsubr (&Scurrent_thread);
+ defsubr (&Sthread_name);
+ defsubr (&Sthread_signal);
+ defsubr (&Sthread_alive_p);
+ defsubr (&Sthread_join);
+ defsubr (&Sthread_blocker);
+ defsubr (&Sall_threads);
+ defsubr (&Smake_mutex);
+ defsubr (&Smutex_lock);
+ defsubr (&Smutex_unlock);
+ defsubr (&Smutex_name);
+ defsubr (&Smake_condition_variable);
+ defsubr (&Scondition_wait);
+ defsubr (&Scondition_notify);
+ defsubr (&Scondition_mutex);
+ defsubr (&Scondition_name);
+ }
+
++ DEFSYM (Qthreadp, "threadp");
++ DEFSYM (Qmutexp, "mutexp");
++ DEFSYM (Qcondition_variable_p, "condition-variable-p");
+}
--- /dev/null
- /* 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)
-
+/* Thread definitions
+ Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef THREAD_H
+#define THREAD_H
+
+#include "regex.h"
+
+#include "sysselect.h" /* FIXME */
+#include "systime.h" /* FIXME */
+
+struct thread_state
+{
+ struct vectorlike_header header;
+
+ /* The buffer in which the last search was performed, or
+ Qt if the last search was done in a string;
+ Qnil if no searching has been done yet. */
+ Lisp_Object m_last_thing_searched;
+#define last_thing_searched (current_thread->m_last_thing_searched)
+
+ Lisp_Object m_saved_last_thing_searched;
+#define saved_last_thing_searched (current_thread->m_saved_last_thing_searched)
+
+ /* The thread's name. */
+ Lisp_Object name;
+
+ /* The thread's function. */
+ Lisp_Object function;
+
+ /* If non-nil, this thread has been signalled. */
+ Lisp_Object error_symbol;
+ Lisp_Object error_data;
+
+ /* If we are waiting for some event, this holds the object we are
+ waiting on. */
+ Lisp_Object event_object;
+
- done. Signalling an error truncates the list analoguous to
- gcprolist. */
++ /* m_byte_stack_list must be the first non-lisp field. */
+ /* A list of currently active byte-code execution value stacks.
+ Fbyte_code adds an entry to the head of this list before it starts
+ processing byte-code, and it removed the entry again when it is
- /* Count levels of GCPRO to detect failure to UNGCPRO. */
- int m_gcpro_level;
- #define gcpro_level (current_thread->m_gcpro_level)
++ done. Signalling an error truncates the list. */
+ struct byte_stack *m_byte_stack_list;
+#define byte_stack_list (current_thread->m_byte_stack_list)
+
+ /* An address near the bottom of the stack.
+ Tells GC how to save a copy of the stack. */
+ char *m_stack_bottom;
+#define stack_bottom (current_thread->m_stack_bottom)
+
+ /* An address near the top of the stack. */
+ char *stack_top;
+
+ struct catchtag *m_catchlist;
+#define catchlist (current_thread->m_catchlist)
+
+ /* Chain of condition handlers currently in effect.
+ The elements of this chain are contained in the stack frames
+ of Fcondition_case and internal_condition_case.
+ When an error is signaled (by calling Fsignal, below),
+ this chain is searched for an element that applies. */
+ struct handler *m_handlerlist;
+#define handlerlist (current_thread->m_handlerlist)
+
- typedef int select_func (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *,
- EMACS_TIME *, sigset_t *);
++ struct handler *m_handlerlist_sentinel;
++#define handlerlist_sentinel (current_thread->m_handlerlist_sentinel)
+
+ /* Current number of specbindings allocated in specpdl. */
+ ptrdiff_t m_specpdl_size;
+#define specpdl_size (current_thread->m_specpdl_size)
+
+ /* Pointer to beginning of specpdl. */
+ union specbinding *m_specpdl;
+#define specpdl (current_thread->m_specpdl)
+
+ /* Pointer to first unused element in specpdl. */
+ union specbinding *m_specpdl_ptr;
+#define specpdl_ptr (current_thread->m_specpdl_ptr)
+
+ /* Depth in Lisp evaluations and function calls. */
+ EMACS_INT m_lisp_eval_depth;
+#define lisp_eval_depth (current_thread->m_lisp_eval_depth)
+
+ /* This points to the current buffer. */
+ struct buffer *m_current_buffer;
+#define current_buffer (current_thread->m_current_buffer)
+
+ /* Every call to re_match, etc., must pass &search_regs as the regs
+ argument unless you can show it is unnecessary (i.e., if re_match
+ is certainly going to be called again before region-around-match
+ can be called).
+
+ Since the registers are now dynamically allocated, we need to make
+ sure not to refer to the Nth register before checking that it has
+ been allocated by checking search_regs.num_regs.
+
+ The regex code keeps track of whether it has allocated the search
+ buffer using bits in the re_pattern_buffer. This means that whenever
+ you compile a new pattern, it completely forgets whether it has
+ allocated any registers, and will allocate new registers the next
+ time you call a searching or matching function. Therefore, we need
+ to call re_set_registers after compiling a new pattern or after
+ setting the match registers, so that the regex functions will be
+ able to free or re-allocate it properly. */
+ struct re_registers m_search_regs;
+#define search_regs (current_thread->m_search_regs)
+
+ /* If non-zero the match data have been saved in saved_search_regs
+ during the execution of a sentinel or filter. */
+ bool m_search_regs_saved;
+#define search_regs_saved (current_thread->m_search_regs_saved)
+
+ struct re_registers m_saved_search_regs;
+#define saved_search_regs (current_thread->m_saved_search_regs)
+
+ /* This is the string or buffer in which we
+ are matching. It is used for looking up syntax properties. */
+ Lisp_Object m_re_match_object;
+#define re_match_object (current_thread->m_re_match_object)
+
+ /* Set by `re_set_syntax' to the current regexp syntax to recognize. Can
+ also be assigned to arbitrarily: each pattern buffer stores its own
+ syntax, so it can be changed between regex compilations. */
+ reg_syntax_t m_re_syntax_options;
+#define re_syntax_options (current_thread->m_re_syntax_options)
+
+ /* Regexp to use to replace spaces, or NULL meaning don't. */
+ /* This ought to be a "const re_char *" but that is not available
+ outside regex.h. */
+ const void *m_whitespace_regexp;
+#define whitespace_regexp (current_thread->m_whitespace_regexp)
+
+ /* This variable is different from waiting_for_input in keyboard.c.
+ It is used to communicate to a lisp process-filter/sentinel (via the
+ function Fwaiting_for_user_input_p) whether Emacs was waiting
+ for user-input when that process-filter was called.
+ waiting_for_input cannot be used as that is by definition 0 when
+ lisp code is being evalled.
+ This is also used in record_asynch_buffer_change.
+ For that purpose, this must be 0
+ when not inside wait_reading_process_output. */
+ int m_waiting_for_user_input_p;
+#define waiting_for_user_input_p (current_thread->m_waiting_for_user_input_p)
+
+ /* The OS identifier for this thread. */
+ sys_thread_t thread_id;
+
+ /* The condition variable for this thread. This is associated with
+ the global lock. This thread broadcasts to it when it exits. */
+ sys_cond_t thread_condvar;
+
+ /* This thread might be waiting for some condition. If so, this
+ points to the condition. If the thread is interrupted, the
+ interrupter should broadcast to this condition. */
+ sys_cond_t *wait_condvar;
+
+ /* Threads are kept on a linked list. */
+ struct thread_state *next_thread;
+};
+
+/* A mutex in lisp is represented by a system condition variable.
+ The system mutex associated with this condition variable is the
+ global lock.
+
+ Using a condition variable lets us implement interruptibility for
+ lisp mutexes. */
+typedef struct
+{
+ /* The owning thread, or NULL if unlocked. */
+ struct thread_state *owner;
+ /* The lock count. */
+ unsigned int count;
+ /* The underlying system condition variable. */
+ sys_cond_t condition;
+} lisp_mutex_t;
+
+/* A mutex as a lisp object. */
+struct Lisp_Mutex
+{
+ struct vectorlike_header header;
+
+ /* The name of the mutex, or nil. */
+ Lisp_Object name;
+
+ /* The lower-level mutex object. */
+ lisp_mutex_t mutex;
+};
+
+/* A condition variable as a lisp object. */
+struct Lisp_CondVar
+{
+ struct vectorlike_header header;
+
+ /* The associated mutex. */
+ Lisp_Object mutex;
+
+ /* The name of the condition variable, or nil. */
+ Lisp_Object name;
+
+ /* The lower-level condition variable object. */
+ sys_cond_t cond;
+};
+
+extern struct thread_state *current_thread;
+
+extern void unmark_threads (void);
+extern void finalize_one_thread (struct thread_state *state);
+extern void finalize_one_mutex (struct Lisp_Mutex *);
+extern void finalize_one_condvar (struct Lisp_CondVar *);
+
+extern void init_threads_once (void);
+extern void init_threads (void);
+extern void syms_of_threads (void);
+
- int thread_select (select_func *func, int max_fds, SELECT_TYPE *rfds,
- SELECT_TYPE *wfds, SELECT_TYPE *efds, EMACS_TIME *timeout,
++typedef int select_func (int, fd_set *, fd_set *, fd_set *,
++ struct timespec *, sigset_t *);
+
++int thread_select (select_func *func, int max_fds, fd_set *rfds,
++ fd_set *wfds, fd_set *efds, struct timespec *timeout,
+ sigset_t *sigmask);
+
+bool thread_check_current_buffer (struct buffer *);
+
+#endif /* THREAD_H */
static int restore_privilege (TOKEN_PRIVILEGES *);
static BOOL WINAPI revert_to_self (void);
- extern int sys_access (const char *, int);
+ static 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 *, sigset_t *);
- struct timespec *, void *);
++ struct timespec *, sigset_t *);
extern int sys_dup (int);
int
sys_select (int nfds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds,
- EMACS_TIME *timeout, sigset_t *ignored)
- struct timespec *timeout, void *ignored)
++ struct timespec *timeout, sigset_t *ignored)
{
- SELECT_TYPE orfds;
+ SELECT_TYPE orfds, owfds;
DWORD timeout_ms, start_time;
int i, nh, nc, nr;
DWORD active;
data->frame_lines = FRAME_LINES (f);
data->frame_menu_bar_lines = FRAME_MENU_BAR_LINES (f);
data->frame_tool_bar_lines = FRAME_TOOL_BAR_LINES (f);
+ data->frame_text_width = FRAME_TEXT_WIDTH (f);
+ data->frame_text_height = FRAME_TEXT_HEIGHT (f);
+ data->frame_menu_bar_height = FRAME_MENU_BAR_HEIGHT (f);
+ data->frame_tool_bar_height = FRAME_TOOL_BAR_HEIGHT (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);
#include <glib.h>
#include <errno.h>
- #include "frame.h"
+ #include <stdbool.h>
+ #include "blockinput.h"
+ #include "systime.h"
+
+ /* `xg_select' is a `pselect' replacement. Why do we need a separate function?
+ 1. Timeouts. Glib and Gtk rely on timer events. If we did pselect
+ with a greater timeout then the one scheduled by Glib, we would
+ not allow Glib to process its timer events. We want Glib to
+ work smoothly, so we need to reduce our timeout to match Glib.
+ 2. Descriptors. Glib may listen to more file descriptors than we do.
+ So we add Glib descriptors to our pselect pool, but we don't change
+ the value returned by the function. The return value matches only
+ the descriptors passed as arguments, making it compatible with
+ plain pselect. */
int
- xg_select (int fds_lim, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds,
- EMACS_TIME *timeout, sigset_t *sigmask)
+ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds,
+ struct timespec const *timeout, sigset_t const *sigmask)
{
- SELECT_TYPE all_rfds, all_wfds;
- EMACS_TIME tmo, *tmop = timeout;
+ fd_set all_rfds, all_wfds;
+ struct timespec tmo;
+ struct timespec const *tmop = timeout;
GMainContext *context;
- int have_wfds = wfds != NULL;
+ bool have_wfds = wfds != NULL;
GPollFD gfds_buf[128];
GPollFD *gfds = gfds_buf;
- int gfds_size = sizeof gfds_buf / sizeof *gfds_buf;
+ int gfds_size = ARRAYELTS (gfds_buf);
int n_gfds, retval = 0, our_fds = 0, max_fds = fds_lim - 1;
- int i, nfds, tmo_in_millisec;
+ bool context_acquired = false;
-
- /* 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
- second, and Emacs has a timeout for 1 second, g_main_context_pending will
- return false, but the timeout will be 1 second, thus missing the gdk
- timeout with a lot. */
+ int i, nfds, tmo_in_millisec, must_free = 0;
- USE_SAFE_ALLOCA;
+ bool need_to_dispatch;
context = g_main_context_default ();
+ context_acquired = g_main_context_acquire (context);
+ /* FIXME: If we couldn't acquire the context, we just silently proceed
+ because this function handles more than just glib file descriptors.
+ Note that, as implemented, this failure is completely silent: there is
+ no feedback to the caller. */
if (rfds) all_rfds = *rfds;
else FD_ZERO (&all_rfds);
if (wfds) all_wfds = *wfds;
else FD_ZERO (&all_wfds);
- n_gfds = g_main_context_query (context, G_PRIORITY_LOW, &tmo_in_millisec,
- gfds, gfds_size);
+ n_gfds = (context_acquired
+ ? g_main_context_query (context, G_PRIORITY_LOW, &tmo_in_millisec,
+ gfds, gfds_size)
+ : -1);
+
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);
}
}
- SAFE_FREE ();
+ if (must_free)
+ xfree (gfds);
- if (tmo_in_millisec >= 0)
+ if (n_gfds >= 0 && tmo_in_millisec >= 0)
{
- tmo = make_emacs_time (tmo_in_millisec / 1000,
- 1000 * 1000 * (tmo_in_millisec % 1000));
- if (!timeout || EMACS_TIME_LT (tmo, *timeout))
+ tmo = make_timespec (tmo_in_millisec / 1000,
+ 1000 * 1000 * (tmo_in_millisec % 1000));
+ if (!timeout || timespec_cmp (tmo, *timeout) < 0)
tmop = &tmo;
}
projects / emacs.git / commitdiff