[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Thread support plan with initial patch
|
From: |
NIIBE Yutaka |
|
Subject: |
Re: Thread support plan with initial patch |
|
Date: |
Sat, 7 Apr 2001 14:00:58 +0900 (JST) |
Here's the patch, for your reference.
It (always) loads libguileqthreads and libqthreads at start-up time.
Null-support is not implemented yet.
I think that we can remove GUILE_PTHREAD_COMPAT part. It seems for me
that it tries to let use COOP threads with pthread allocated stack, but
it doesn't work well. I don't know the reason of the cause. I don't
know the reason why we use COOP with pthread.
Index: GUILE-VERSION
===================================================================
RCS file: /cvs/guile/guile-core/GUILE-VERSION,v
retrieving revision 1.22
diff -u -r1.22 GUILE-VERSION
--- GUILE-VERSION 2000/10/25 14:44:42 1.22
+++ GUILE-VERSION 2001/04/07 04:40:35
@@ -11,3 +11,9 @@
LIBGUILE_MINOR_VERSION=0
LIBGUILE_REVISION_VERSION=0
LIBGUILE_VERSION=${LIBGUILE_MAJOR_VERSION}.${LIBGUILE_MINOR_VERSION}.${LIBGUILE_REVISION_VERSION}
+
+# libguileqthreads.so versioning info
+LIBGUILEQTHREADS_MAJOR_VERSION=0
+LIBGUILEQTHREADS_MINOR_VERSION=0
+LIBGUILEQTHREADS_REVISION_VERSION=0
+LIBGUILEQTHREADS_VERSION=${LIBGUILEQTHREADS_MAJOR_VERSION}.${LIBGUILEQTHREADS_MINOR_VERSION}.${LIBGUILEQTHREADS_REVISION_VERSION}
Index: configure.in
===================================================================
RCS file: /cvs/guile/guile-core/configure.in,v
retrieving revision 1.129
diff -u -r1.129 configure.in
--- configure.in 2001/03/18 23:17:32 1.129
+++ configure.in 2001/04/07 04:40:36
@@ -195,7 +195,7 @@
AC_SUBST(LIBLTDL)
AC_SUBST(DLPREOPEN)
-AC_CHECK_FUNCS(ctermid ftime fchown getcwd geteuid gettimeofday lstat mkdir
mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid
setsid sigaction siginterrupt strftime strptime symlink sync tcgetpgrp
tcsetpgrp times uname waitpid bzero strdup system usleep atexit on_exit)
+AC_CHECK_FUNCS(ctermid ftime fchown getcwd geteuid gettimeofday lstat mkdir
mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid
setsid sigaction siginterrupt strftime strptime symlink sync tcgetpgrp
tcsetpgrp times uname waitpid strdup system usleep atexit on_exit)
AC_CHECK_HEADERS(crypt.h sys/resource.h sys/file.h)
AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass
sethostname gethostname)
@@ -219,7 +219,6 @@
])
GUILE_FUNC_DECLARED(strptime, time.h)
-GUILE_FUNC_DECLARED(bzero, string.h)
GUILE_FUNC_DECLARED(sleep, unistd.h)
GUILE_FUNC_DECLARED(usleep, unistd.h)
@@ -472,16 +471,6 @@
## Include the Guile thread interface in the library...
LIBOBJS="$LIBOBJS threads.o"
- ## ... and tell it which package to talk to.
- case "${THREAD_PACKAGE}" in
- "QT" )
- AC_DEFINE(USE_COOP_THREADS, 1)
- ;;
- * )
- AC_MSG_ERROR(invalid value for THREAD_PACKAGE: ${THREAD_PACKAGE})
- ;;
- esac
-
## Bring in scm_internal_select, if appropriate.
if test $ac_cv_func_gettimeofday = yes &&
test $ac_cv_func_select = yes; then
@@ -489,10 +478,14 @@
fi
## Workaround for linuxthreads (currently disabled)
- if test $host_os = linux-gnu; then
- AC_DEFINE(GUILE_PTHREAD_COMPAT, 1)
- AC_CHECK_LIB(pthread, main)
- fi
+## if test $host_os = linux-gnu; then
+ ## AC_DEFINE(GUILE_PTHREAD_COMPAT, 1)
+## AC_CHECK_LIB(pthread, main)
+## fi
+ AC_SUBST(LIBGUILEQTHREADS_MAJOR_VERSION)
+ AC_SUBST(LIBGUILEQTHREADS_MINOR_VERSION)
+ AC_SUBST(LIBGUILEQTHREADS_REVISION_VERSION)
+ AC_SUBST(LIBGUILEQTHREADS_VERSION)
fi
## If we're using GCC, ask for aggressive warnings.
@@ -526,7 +519,7 @@
AC_SUBST(LIBGUILE_VERSION)
dnl Tell guile-config what flags guile users should link against.
-GUILE_LIBS="$LDFLAGS $THREAD_LIBS_INSTALLED $LIBS"
+GUILE_LIBS="$LDFLAGS $LIBS"
AC_SUBST(GUILE_LIBS)
AC_SUBST(AWK)
Index: guile-readline/readline.c
===================================================================
RCS file: /cvs/guile/guile-core/guile-readline/readline.c,v
retrieving revision 1.30
diff -u -r1.30 readline.c
--- guile-readline/readline.c 2001/03/09 23:31:55 1.30
+++ guile-readline/readline.c 2001/04/07 04:40:36
@@ -147,7 +147,7 @@
static int in_readline = 0;
#ifdef USE_THREADS
-static scm_mutex_t reentry_barrier_mutex;
+static SCM reentry_barrier_mutex;
#endif
static SCM internal_readline (SCM text);
@@ -226,14 +226,14 @@
int reentryp = 0;
#ifdef USE_THREADS
/* We should rather use scm_mutex_try_lock when it becomes available */
- scm_mutex_lock (&reentry_barrier_mutex);
+ scm_mutex_lock (reentry_barrier_mutex);
#endif
if (in_readline)
reentryp = 1;
else
++in_readline;
#ifdef USE_THREADS
- scm_mutex_unlock (&reentry_barrier_mutex);
+ scm_mutex_unlock (reentry_barrier_mutex);
#endif
if (reentryp)
scm_misc_error (s_scm_readline, "readline is not reentrant", SCM_EOL);
@@ -543,7 +543,8 @@
#endif
#ifdef USE_THREADS
- scm_mutex_init (&reentry_barrier_mutex);
+ reentry_barrier_mutex = scm_make_mutex ();
+ scm_protect_object (reentry_barrier_mutex);
#endif
scm_init_opts (scm_readline_options,
scm_readline_opts,
Index: libguile/Makefile.am
===================================================================
RCS file: /cvs/guile/guile-core/libguile/Makefile.am,v
retrieving revision 1.126
diff -u -r1.126 Makefile.am
--- libguile/Makefile.am 2001/03/17 21:20:20 1.126
+++ libguile/Makefile.am 2001/04/07 04:40:36
@@ -31,11 +31,11 @@
ETAGS_ARGS =
--regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/'
\
--regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/'
-lib_LTLIBRARIES = libguile.la
+lib_LTLIBRARIES = libguile.la libguileqthreads.la
bin_PROGRAMS = guile
guile_SOURCES = guile.c
-guile_LDADD = libguile.la ${THREAD_LIBS_LOCAL}
+guile_LDADD = libguile.la
guile_LDFLAGS = @DLPREOPEN@
libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
@@ -90,16 +90,16 @@
filesys.c posix.c net_db.c socket.c \
ramap.c unif.c debug-malloc.c
-## In next release, threads will be factored out of libguile.
-## Until then, the machine specific headers is a temporary kludge.
-OMIT_DEPENDENCIES = libguile.h ltdl.h \
- axp.h hppa.h i386.h ksr.h m88k.h mips.h sparc.h vax.h
-
## This is kind of nasty... there are ".c" files that we don't want to
## compile, since they are #included in threads.c. So instead we list
## them here. Perhaps we can deal with them normally once the merge
## seems to be working.
-noinst_HEADERS = coop-threads.c coop-threads.h coop.c
+noinst_HEADERS = coop.h
+
+libguileqthreads_la_SOURCES = guile-coop.c coop.c
+libguileqthreads_la_DEPENDENCIES =
+libguileqthreads_la_LIBADD = ${THREAD_LIBS_LOCAL}
+libguileqthreads_la_LDFLAGS = -version-info
@LIBGUILEQTHREADS_MAJOR_VERSION@:@LIBGUILEQTHREADS_MINOR_VERSION@:@LIBGUILEQTHREADS_REVISION_VERSION@
libguile_la_DEPENDENCIES = @LIBLOBJS@
libguile_la_LIBADD = @LIBLOBJS@ $(LIBLTDL)
@@ -111,7 +111,7 @@
# These are headers visible as <libguile/mumble.h>.
modincludedir = $(includedir)/libguile
modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \
- chars.h continuations.h coop-defs.h debug.h debug-malloc.h \
+ chars.h continuations.h debug.h debug-malloc.h \
dynl.h dynwind.h environments.h eq.h error.h eval.h evalext.h \
feature.h filesys.h fluids.h fports.h gc.h gdb_interface.h gdbint.h
\
goops.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h ioext.h
\
Index: libguile/__scm.h
===================================================================
RCS file: /cvs/guile/guile-core/libguile/__scm.h,v
retrieving revision 1.65
diff -u -r1.65 __scm.h
--- libguile/__scm.h 2001/03/17 13:34:21 1.65
+++ libguile/__scm.h 2001/04/07 04:40:36
@@ -319,10 +319,23 @@
#ifndef USE_THREADS
-#define SCM_THREAD_DEFER
-#define SCM_THREAD_ALLOW
-#define SCM_THREAD_REDEFER
+#define SCM_THREAD_CRITICAL_SECTION_START
+#define SCM_THREAD_CRITICAL_SECTION_END
#define SCM_THREAD_SWITCHING_CODE
+#else
+#define SCM_THREAD_SWITCH_COUNT 50 /* was 10 /mdj */
+#define SCM_THREAD_SWITCHING_CODE \
+do { \
+ if (scm_thread_count > 1) \
+ { \
+ scm_switch_counter--; \
+ if (scm_switch_counter == 0) \
+ { \
+ scm_switch_counter = SCM_THREAD_SWITCH_COUNT; \
+ scm_c_thread_yield (); \
+ } \
+ } \
+} while (0)
#endif
#ifdef GUILE_OLD_ASYNC_CLICK
@@ -344,13 +357,18 @@
#endif
#ifdef SCM_CAREFUL_INTS
+#include <stdio.h>
#define SCM_CHECK_NOT_DISABLED \
+do { \
if (scm_ints_disabled) \
- fputs("ints already disabled\n", stderr); \
+ fprintf(stderr, "ints already disabled (at %s:%d)\n", __FILE__, __LINE__);
\
+} while (0)
#define SCM_CHECK_NOT_ENABLED \
+do { \
if (!scm_ints_disabled) \
- fputs("ints already enabled\n", stderr); \
+ fprintf(stderr, "ints already enabled (at %s:%d)\n", __FILE__, __LINE__); \
+} while (0)
#else
#define SCM_CHECK_NOT_DISABLED
@@ -383,7 +401,7 @@
do { \
SCM_FENCE; \
SCM_CHECK_NOT_DISABLED; \
- SCM_THREAD_DEFER; \
+ SCM_THREAD_CRITICAL_SECTION_START; \
SCM_FENCE; \
scm_ints_disabled = 1; \
SCM_FENCE; \
@@ -392,7 +410,7 @@
#define SCM_ALLOW_INTS_ONLY \
do { \
- SCM_THREAD_ALLOW; \
+ SCM_THREAD_CRITICAL_SECTION_END; \
scm_ints_disabled = 0; \
} while (0)
@@ -401,11 +419,11 @@
do { \
SCM_FENCE; \
SCM_CHECK_NOT_ENABLED; \
- SCM_THREAD_SWITCHING_CODE; \
+ SCM_THREAD_CRITICAL_SECTION_END; \
SCM_FENCE; \
scm_ints_disabled = 0; \
SCM_FENCE; \
- SCM_THREAD_ALLOW; \
+ SCM_THREAD_SWITCHING_CODE; \
SCM_FENCE; \
} while (0)
@@ -413,7 +431,7 @@
#define SCM_REDEFER_INTS \
do { \
SCM_FENCE; \
- SCM_THREAD_REDEFER; \
+ SCM_THREAD_CRITICAL_SECTION_START; \
++scm_ints_disabled; \
SCM_FENCE; \
} while (0)
@@ -422,7 +440,7 @@
#define SCM_REALLOW_INTS \
do { \
SCM_FENCE; \
- SCM_THREAD_SWITCHING_CODE; \
+ SCM_THREAD_CRITICAL_SECTION_END; \
SCM_FENCE; \
--scm_ints_disabled; \
SCM_FENCE; \
@@ -431,9 +449,8 @@
#define SCM_TICK \
do { \
- SCM_DEFER_INTS; \
- SCM_ALLOW_INTS; \
SCM_ASYNC_TICK; \
+ SCM_THREAD_SWITCHING_CODE; \
} while (0)
@@ -466,13 +483,8 @@
* at all times.
*/
-#ifdef SCM_POSIX_THREADS
-#define SCM_ENTER_A_SECTION
-#define SCM_EXIT_A_SECTION
-#else
-#define SCM_ENTER_A_SECTION SCM_DEFER_INTS
-#define SCM_EXIT_A_SECTION SCM_ALLOW_INTS
-#endif
+#define SCM_ENTER_A_SECTION SCM_THREAD_CRITICAL_SECTION_START
+#define SCM_EXIT_A_SECTION SCM_THREAD_CRITICAL_SECTION_END
cvs server: cannot find libguile/coop-defs.h
cvs server: cannot find libguile/coop-threads.c
cvs server: cannot find libguile/coop-threads.h
Index: libguile/coop.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/coop.c,v
retrieving revision 1.27
diff -u -r1.27 coop.c
--- libguile/coop.c 2001/03/10 03:09:07 1.27
+++ libguile/coop.c 2001/04/07 04:40:37
@@ -44,19 +44,22 @@
/* Cooperative thread library, based on QuickThreads */
-#include <stdio.h>
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
+#include "coop.h"
+#include <stdio.h>
#include <errno.h>
#include "qt/qt.h"
#include "libguile/eval.h"
+
+static void init_iselect (void);
+static coop_t * coop_next_runnable_thread (void);
+static coop_t * coop_wait_for_runnable_thread (void);
- /* #define COOP_STKSIZE (0x10000) */
-#define COOP_STKSIZE (scm_eval_stack)
+
+/* Dirk:Note:: had to change this in order not to use references to guile */
+#define COOP_STKSIZE (0x10000)
+/* #define COOP_STKSIZE (scm_eval_stack) */
/* `alignment' must be a power of 2. */
#define COOP_STKALIGN(sp, alignment) \
@@ -83,7 +86,8 @@
}
-coop_t *
+/* Dirk:Note:: This was externally visible, but only for iselect.c */
+static coop_t *
coop_qget (coop_q_t *q)
{
coop_t *t;
@@ -102,7 +106,8 @@
}
-void
+/* Dirk:Note:: This was externally visible, but only for iselect.c */
+static void
coop_qput (coop_q_t *q, coop_t *t)
{
q->tail->next = t;
@@ -110,7 +115,8 @@
q->tail = t;
}
-static void
+/* Dirk:Note:: This was static, but is needed(?) for
guile-coop.c:scm_threads_init */
+void
coop_all_qput (coop_q_t *q, coop_t *t)
{
if (q->t.all_next)
@@ -135,7 +141,8 @@
/* Insert thread t into the ordered queue q.
q is ordered after wakeup_time. Threads which aren't sleeping but
waiting for I/O go last into the queue. */
-void
+/* Dirk:Note:: This was externally visible, but only for iselect.c */
+static void
coop_timeout_qinsert (coop_q_t *q, coop_t *t)
{
coop_t *pred = &q->t;
@@ -158,10 +165,13 @@
/* Thread routines. */
coop_q_t coop_global_runq; /* A queue of runable threads. */
-coop_q_t coop_global_sleepq; /* A queue of sleeping threads. */
-coop_q_t coop_tmp_queue; /* A temp working queue */
+/* Dirk:Note:: This was externally visible, but only for iselect.c */
+static coop_q_t coop_global_sleepq; /* A queue of sleeping threads. */
+/* Dirk:Note:: This was externally visible, but only for iselect.c */
+static coop_q_t coop_tmp_queue; /* A temp working queue */
coop_q_t coop_global_allq; /* A queue of all threads. */
-static coop_t coop_global_main; /* Thread for the process. */
+/* Dirk:Note:: This was static, but is needed(?) for
guile-coop.c:scm_threads_init */
+coop_t coop_global_main; /* Thread for the process. */
coop_t *coop_global_curr; /* Currently-executing thread. */
#ifdef GUILE_PTHREAD_COMPAT
@@ -179,6 +189,8 @@
static void *coop_aborthelp (qt_t *sp, void *old, void *null);
static void *coop_yieldhelp (qt_t *sp, void *old, void *blockq);
+static int I_am_dead;
+
/* called on process termination. */
#ifdef HAVE_ATEXIT
@@ -205,6 +217,11 @@
void
coop_init ()
{
+ /* Dirk:FIXME:: This is a temporary solution, in order not to change the
+ * code too much at the moment.
+ */
+ init_iselect ();
+
coop_qinit (&coop_global_runq);
coop_qinit (&coop_global_sleepq);
coop_qinit (&coop_tmp_queue);
@@ -230,7 +247,8 @@
return NULL. */
#ifndef GUILE_ISELECT
-coop_t *
+/* Dirk:Note:: This was externally visible, but only for iselect.c */
+static coop_t *
coop_next_runnable_thread()
{
int sleepers;
@@ -570,6 +588,7 @@
do
res = pthread_cond_wait (&coop_cond_quit, &t->dummy_mutex);
while (res == EINTR);
+ pthread_mutex_unlock (&t->dummy_mutex);
return 0;
}
@@ -588,6 +607,7 @@
res = pthread_cond_wait (&coop_cond_create, &coop_mutex_create);
while (res == EINTR);
}
+ pthread_mutex_unlock (&coop_mutex_create);
return 0;
}
@@ -680,11 +700,11 @@
}
#ifdef GUILE_ISELECT
- scm_I_am_dead = 1;
+ I_am_dead = 1;
do {
newthread = coop_wait_for_runnable_thread();
} while (newthread == coop_global_curr);
- scm_I_am_dead = 0;
+ I_am_dead = 0;
#else
newthread = coop_next_runnable_thread();
#endif
@@ -773,7 +793,8 @@
/* Replacement for the system's sleep() function. Does the right thing
for the process - but not for the system (it busy-waits) */
-void *
+/* Dirk:Note:: This was externally visible, but only for iselect.c */
+static void *
coop_sleephelp (qt_t *sp, void *old, void *blockq)
{
((coop_t *)old)->sp = sp;
@@ -783,66 +804,650 @@
}
#ifdef GUILE_ISELECT
+
+/*****************************************************************************
+Here starts the content of iselect.c:
+*****************************************************************************/
+
+
+
+/* COOP queue macros */
+#define QEMPTYP(q) (q.t.next == &q.t)
+#define QFIRST(q) (q.t.next)
+
+/* These macros count the number of bits in a word. */
+#define SCM_BITS_PER_LONG (8 * sizeof (unsigned long))
+/* Use LONG_MAX instead of ULONG_MAX here since not all systems define
+ ULONG_MAX */
+#if LONG_MAX >> 16 == 0
+#define SCM_NLONGBITS(p) (bc[((unsigned char *)(p))[0]]\
+ + bc[((unsigned char *)(p))[1]])
+#elif LONG_MAX >> 32 == 0 || LONG_MAX == 2147483647L /* bug in Sun CC 4.2 */
+#define SCM_NLONGBITS(p) (bc[((unsigned char *)(p))[0]]\
+ + bc[((unsigned char *)(p))[1]]\
+ + bc[((unsigned char *)(p))[2]]\
+ + bc[((unsigned char *)(p))[3]])
+#elif LONG_MAX >> 64 == 0
+#define SCM_NLONGBITS(p) (bc[((unsigned char *)(p))[0]]\
+ + bc[((unsigned char *)(p))[1]]\
+ + bc[((unsigned char *)(p))[2]]\
+ + bc[((unsigned char *)(p))[3]]\
+ + bc[((unsigned char *)(p))[4]]\
+ + bc[((unsigned char *)(p))[5]]\
+ + bc[((unsigned char *)(p))[6]]\
+ + bc[((unsigned char *)(p))[7]])
+#else
+#error Could not determine suitable definition for SCM_NLONGBITS
+#endif
-unsigned long
-scm_thread_usleep (unsigned long usec)
+#define FD_ZERO_N(pos, n) memset ((void *) (pos), 0, (n))
+
+typedef unsigned long *ulongptr;
+
+static char bc[256]; /* Bit counting array. bc[x] is the number of
+ bits in x. */
+
+/* This flag indicates that several threads are waiting on the same
+ file descriptor. When this is the case, the common fd sets are
+ updated in a more inefficient way. */
+int collisionp;
+
+/* These are the common fd sets. When new select calls are made,
+ those sets are merged into these. */
+int gnfds;
+SELECT_TYPE greadfds;
+SELECT_TYPE gwritefds;
+SELECT_TYPE gexceptfds;
+
+/* These are the result sets. They are used when we call OS select.
+ We couldn't use the common fd sets above, since that would destroy
+ them. */
+SELECT_TYPE rreadfds;
+SELECT_TYPE rwritefds;
+SELECT_TYPE rexceptfds;
+
+/* Constant timeval struct representing a zero timeout which we use
+ when polling. */
+static struct timeval timeout0;
+
+/* As select, but doesn't destroy the file descriptor sets passed as
+ arguments. The results are stored into the result sets. */
+static int
+safe_select (int nfds,
+ SELECT_TYPE *readfds,
+ SELECT_TYPE *writefds,
+ SELECT_TYPE *exceptfds,
+ struct timeval *timeout)
+{
+ int n = (nfds + 7) / 8;
+ /* Copy file descriptor sets to result area */
+ if (readfds == NULL)
+ FD_ZERO (&rreadfds);
+ else
+ {
+ memcpy (&rreadfds, readfds, n);
+ FD_ZERO_N ((char *) &rreadfds + n, SELECT_SET_SIZE / 8 - n);
+ }
+ if (writefds == NULL)
+ FD_ZERO (&rwritefds);
+ else
+ {
+ memcpy (&rwritefds, writefds, n);
+ FD_ZERO_N ((char *) &rwritefds + n, SELECT_SET_SIZE / 8 - n);
+ }
+ if (exceptfds == NULL)
+ FD_ZERO (&rexceptfds);
+ else
+ {
+ memcpy (&rexceptfds, exceptfds, n);
+ FD_ZERO_N ((char *) &rexceptfds + n, SELECT_SET_SIZE / 8 - n);
+ }
+ return select (nfds, &rreadfds, &rwritefds, &rexceptfds, timeout);
+}
+
+/* Merge new file descriptor sets into the common sets. */
+static void
+add_fd_sets (coop_t *t)
{
- struct timeval timeout;
- timeout.tv_sec = 0;
- timeout.tv_usec = usec;
- scm_internal_select (0, NULL, NULL, NULL, &timeout);
- return 0; /* Maybe we should calculate actual time slept,
- but this is faster... :) */
+ int n = (t->nfds + SCM_BITS_PER_LONG - 1) / SCM_BITS_PER_LONG;
+ int i;
+
+ /* Detect if the fd sets of the thread have any bits in common with
+ the rest of the waiting threads. If that is so, set the
+ collision flag. This causes a more time consuming handling of
+ the common fd sets---they need to recalculated every time a
+ thread wakes up. */
+ if (!collisionp)
+ for (i = 0; i < n; ++i)
+ if ((t->readfds != NULL
+ && (((ulongptr) t->readfds)[i] & ((ulongptr) &greadfds)[i]) != 0)
+ || (t->writefds != NULL
+ && ((((ulongptr) t->writefds)[i] & ((ulongptr) &gwritefds)[i])
+ != 0))
+ || (t->exceptfds != NULL
+ && ((((ulongptr) t->exceptfds)[i] & ((ulongptr) &gexceptfds)[i])
+ != 0)))
+ {
+ collisionp = 1;
+ break;
+ }
+
+ /* We recalculate nfds below. The cost for this can be paid back
+ with a great bonus since many programs are lazy with the nfds
+ arg. Many even pass 1024 when using one of the lowest fd:s!
+
+ We approach from above, checking for non-zero bits. As soon as
+ we have determined the value of nfds, we jump down to code below
+ which concludes the updating of the common sets. */
+ t->nfds = 0;
+ i = n;
+ while (i > 0)
+ {
+ --i;
+ if (t->readfds != NULL && ((ulongptr) t->readfds)[i] != 0)
+ {
+ ((ulongptr) &greadfds)[i] |= ((ulongptr) t->readfds)[i];
+ n = (i + 1) * SCM_BITS_PER_LONG;
+ t->nfds = n;
+ if (n > gnfds)
+ gnfds = n;
+ goto cont_read;
+ }
+ if (t->writefds != NULL && ((ulongptr) t->writefds)[i] != 0)
+ {
+ ((ulongptr) &gwritefds)[i] |= ((ulongptr) t->writefds)[i];
+ n = (i + 1) * SCM_BITS_PER_LONG;
+ t->nfds = n;
+ if (n > gnfds)
+ gnfds = n;
+ goto cont_write;
+ }
+ if (t->exceptfds != NULL && ((ulongptr) t->exceptfds)[i] != 0)
+ {
+ ((ulongptr) &gexceptfds)[i] |= ((ulongptr) t->exceptfds)[i];
+ n = (i + 1) * SCM_BITS_PER_LONG;
+ t->nfds = n;
+ if (n > gnfds)
+ gnfds = n;
+ goto cont_except;
+ }
+ }
+ return;
+
+ /* nfds is now determined. Just finish updating the common sets. */
+ while (i > 0)
+ {
+ --i;
+ if (t->readfds != NULL && ((ulongptr) t->readfds)[i] != 0)
+ ((ulongptr) &greadfds)[i] |= ((ulongptr) t->readfds)[i];
+ cont_read:
+ if (t->writefds != NULL && ((ulongptr) t->writefds)[i] != 0)
+ ((ulongptr) &gwritefds)[i] |= ((ulongptr) t->writefds)[i];
+ cont_write:
+ if (t->exceptfds != NULL && ((ulongptr) t->exceptfds)[i] != 0)
+ ((ulongptr) &gexceptfds)[i] |= ((ulongptr) t->exceptfds)[i];
+ cont_except:
+ ;
+ }
}
-unsigned long
-scm_thread_sleep (unsigned long sec)
+/* Update the fd sets pointed to by the thread so that they reflect
+ the status of the file descriptors which the thread was interested
+ in. Also clear those bits in the common sets. This function is
+ only called when there are no bit collisions. */
+static void
+finalize_fd_sets (coop_t *t)
{
- time_t now = time (NULL);
- struct timeval timeout;
- unsigned long slept;
- timeout.tv_sec = sec;
- timeout.tv_usec = 0;
- scm_internal_select (0, NULL, NULL, NULL, &timeout);
- slept = time (NULL) - now;
- return slept > sec ? 0 : sec - slept;
+ int i = (t->nfds + SCM_BITS_PER_LONG - 1) / SCM_BITS_PER_LONG;
+ int n_ones = 0;
+ register unsigned long s;
+
+ if (t->nfds == gnfds)
+ {
+ /* This thread is the one responsible for the current high value
+ of gnfds. First do our other jobs while at the same time
+ trying to decrease gnfds. */
+ while (i > 0)
+ {
+ --i;
+ if (t->readfds != NULL && (s = ((ulongptr) t->readfds)[i]) != 0)
+ {
+ ((ulongptr) t->readfds)[i] &= ((ulongptr) &rreadfds)[i];
+ ((ulongptr) &greadfds)[i] &= ~s;
+ n_ones += SCM_NLONGBITS (&((ulongptr) t->readfds)[i]);
+ }
+ if (((ulongptr) &greadfds)[i] != 0)
+ {
+ gnfds = (i + 1) * SCM_BITS_PER_LONG;
+ goto cont_read;
+ }
+ if (t->writefds != NULL && (s = ((ulongptr) t->writefds)[i]) != 0)
+ {
+ ((ulongptr) t->writefds)[i] &= ((ulongptr) &rwritefds)[i];
+ ((ulongptr) &gwritefds)[i] &= ~s;
+ n_ones += SCM_NLONGBITS (&((ulongptr) t->writefds)[i]);
+ }
+ if (((ulongptr) &gwritefds)[i] != 0)
+ {
+ gnfds = (i + 1) * SCM_BITS_PER_LONG;
+ goto cont_write;
+ }
+ if (t->exceptfds != NULL && (s = ((ulongptr) t->exceptfds)[i]) != 0)
+ {
+ ((ulongptr) t->exceptfds)[i] &= ((ulongptr) &rexceptfds)[i];
+ ((ulongptr) &gexceptfds)[i] &= ~s;
+ n_ones += SCM_NLONGBITS (&((ulongptr) t->exceptfds)[i]);
+ }
+ if (((ulongptr) &gexceptfds)[i] != 0)
+ {
+ gnfds = (i + 1) * SCM_BITS_PER_LONG;
+ goto cont_except;
+ }
+ }
+ gnfds = 0;
+ t->retval = n_ones;
+ return;
+ }
+
+ /* Either this thread wasn't responsible for gnfds or gnfds has been
+ determined. */
+ while (i > 0)
+ {
+ --i;
+ if (t->readfds != NULL && (s = ((ulongptr) t->readfds)[i]) != 0)
+ {
+ ((ulongptr) t->readfds)[i] &= ((ulongptr) &rreadfds)[i];
+ ((ulongptr) &greadfds)[i] &= ~s;
+ n_ones += SCM_NLONGBITS (&((ulongptr) t->readfds)[i]);
+ }
+ cont_read:
+ if (t->writefds != NULL && (s = ((ulongptr) t->writefds)[i]) != 0)
+ {
+ ((ulongptr) t->writefds)[i] &= ((ulongptr) &rwritefds)[i];
+ ((ulongptr) &gwritefds)[i] &= ~s;
+ n_ones += SCM_NLONGBITS (&((ulongptr) t->writefds)[i]);
+ }
+ cont_write:
+ if (t->exceptfds != NULL && (s = ((ulongptr) t->exceptfds)[i]) != 0)
+ {
+ ((ulongptr) t->exceptfds)[i] &= ((ulongptr) &rexceptfds)[i];
+ ((ulongptr) &gexceptfds)[i] &= ~s;
+ n_ones += SCM_NLONGBITS (&((ulongptr) t->exceptfds)[i]);
+ }
+ cont_except:
+ ;
+ }
+ t->retval = n_ones;
}
-#else /* GUILE_ISELECT */
+/* Just like finalize_fd_sets except that we don't have to update the
+ global fd sets. Those will be recalulated elsewhere. */
+static void
+finalize_fd_sets_lazily (coop_t *t)
+{
+ int i = (t->nfds + SCM_BITS_PER_LONG - 1) / SCM_BITS_PER_LONG;
+ int n_ones = 0;
+ while (i > 0)
+ {
+ --i;
+ if (t->readfds != NULL && ((ulongptr) t->readfds)[i] != 0)
+ {
+ ((ulongptr) t->readfds)[i] &= ((ulongptr) &rreadfds)[i];
+ n_ones += SCM_NLONGBITS (&((ulongptr) t->readfds)[i]);
+ }
+ if (t->writefds != NULL && ((ulongptr) t->writefds)[i] != 0)
+ {
+ ((ulongptr) t->writefds)[i] &= ((ulongptr) &rwritefds)[i];
+ n_ones += SCM_NLONGBITS (&((ulongptr) t->writefds)[i]);
+ }
+ if (t->exceptfds != NULL && ((ulongptr) t->exceptfds)[i] != 0)
+ {
+ ((ulongptr) t->exceptfds)[i] &= ((ulongptr) &rexceptfds)[i];
+ n_ones += SCM_NLONGBITS (&((ulongptr) t->exceptfds)[i]);
+ }
+ }
+ t->retval = n_ones;
+}
-unsigned long
-scm_thread_sleep (unsigned long s)
+/* Return first fd with a non-zero bit in any of the result sets. */
+static int
+first_interesting_fd (void)
{
- coop_t *newthread, *old;
- time_t now = time (NULL);
- coop_global_curr->wakeup_time = now + s;
+ int i = 0;
+ SELECT_TYPE *s;
+ while (1)
+ {
+ if (((ulongptr) &rreadfds)[i] != 0)
+ {
+ s = &rreadfds;
+ break;
+ }
+ if (((ulongptr) &rwritefds)[i] != 0)
+ {
+ s = &rwritefds;
+ break;
+ }
+ if (((ulongptr) &rexceptfds)[i] != 0)
+ {
+ s = &rexceptfds;
+ break;
+ }
+ ++i;
+ }
+ i *= SCM_BITS_PER_LONG;
+ while (i < gnfds)
+ {
+ if (FD_ISSET (i, s))
+ return i;
+ ++i;
+ }
+ fprintf (stderr, "first_interesting_fd: internal error\n");
+ exit (1);
+}
- /* Put the current thread on the sleep queue */
- coop_qput (&coop_global_sleepq, coop_global_curr);
+/* Revive all threads with an error status. */
+/* Dirk:Note:: This was externally visible, but only for iselect.c */
+static void
+error_revive_threads (void)
+{
+ coop_t *t;
+
+ while ((t = coop_qget (&coop_global_sleepq)) != NULL)
+ {
+ t->_errno = errno;
+ t->retval = -1;
+ if (t != coop_global_curr)
+ coop_qput (&coop_global_runq, t);
+ }
+ collisionp = 0;
+ gnfds = 0;
+ FD_ZERO (&greadfds);
+ FD_ZERO (&gwritefds);
+ FD_ZERO (&gexceptfds);
+}
- newthread = coop_next_runnable_thread();
+/* Given the result of a call to safe_select and the current time,
+ try to wake up some threads and return the first one. Return NULL
+ if we couldn't find any. */
+static coop_t *
+find_thread (int n, struct timeval *now, int sleepingp)
+{
+ coop_t *t;
+ int fd;
- /* If newthread is the same as the sleeping thread, do nothing */
- if (newthread == coop_global_curr)
- return s;
+ if (n < 0)
+ /* An error or a signal has occured. Wake all threads. Since we
+ don't care to calculate if there is a sinner we report the
+ error to all of them. */
+ {
+ error_revive_threads ();
+ if (!I_am_dead)
+ return coop_global_curr;
+ }
+ else if (n == 0)
+ {
+ while (!QEMPTYP (coop_global_sleepq)
+ && (t = QFIRST (coop_global_sleepq))->timeoutp
+ && (t->wakeup_time.tv_sec < now->tv_sec
+ || (t->wakeup_time.tv_sec == now->tv_sec
+ && t->wakeup_time.tv_usec <= now->tv_usec)))
+ {
+ coop_qget (&coop_global_sleepq);
+ if (collisionp)
+ finalize_fd_sets_lazily (t);
+ else
+ finalize_fd_sets (t);
+ coop_qput (&coop_global_runq, t);
+ }
+ if (collisionp)
+ {
+ while ((t = coop_qget (&coop_global_sleepq)) != NULL)
+ coop_qput (&coop_tmp_queue, t);
+ goto rebuild_global_fd_sets;
+ }
+ }
+ else if (n > 0)
+ {
+ /* Find the first interesting file descriptor */
+ fd = first_interesting_fd ();
+ /* Check the sleeping queue for this file descriptor.
+ Other file descriptors will be handled next time
+ coop_next_runnable_thread is called. */
+ /* This code is inefficient. We'll improve it later. */
+ while ((t = coop_qget (&coop_global_sleepq)) != NULL)
+ {
+ if ((t->readfds && FD_ISSET (fd, t->readfds))
+ || (t->writefds && FD_ISSET (fd, t->writefds))
+ || (t->exceptfds && FD_ISSET (fd, t->exceptfds))
+ || (t->timeoutp
+ && (t->wakeup_time.tv_sec < now->tv_sec
+ || (t->wakeup_time.tv_sec == now->tv_sec
+ && t->wakeup_time.tv_usec <= now->tv_usec))))
+ {
+ if (collisionp)
+ finalize_fd_sets_lazily (t);
+ else
+ finalize_fd_sets (t);
+ coop_qput (&coop_global_runq, t);
+ }
+ else
+ coop_qput(&coop_tmp_queue, t);
+ }
+ if (collisionp)
+ {
+ rebuild_global_fd_sets:
+ collisionp = 0;
+ gnfds = 0;
+ FD_ZERO (&greadfds);
+ FD_ZERO (&gwritefds);
+ FD_ZERO (&gexceptfds);
+ while ((t = coop_qget (&coop_tmp_queue)) != NULL)
+ {
+ add_fd_sets (t);
+ coop_qput (&coop_global_sleepq, t);
+ }
+ }
+ else
+ {
+ while ((t = coop_qget (&coop_tmp_queue)) != NULL)
+ coop_qput (&coop_global_sleepq, t);
+ }
+ }
- old = coop_global_curr;
+ return coop_qget (&coop_global_runq);
+}
- coop_global_curr = newthread;
- QT_BLOCK (coop_sleephelp, old, NULL, newthread->sp);
+/* Return next runnable thread on the run queue.
+ * First update the queue with possible I/O or timeouts.
+ * If no thread is found, return NULL.
+ */
+/* Dirk:Note:: This was externally visible, but only for iselect.c */
+static coop_t *
+coop_next_runnable_thread ()
+{
+ coop_t *t;
+ struct timeval now;
+ int n;
+
+ /* Just return next thread on the runq if the sleepq is empty. */
+ if (QEMPTYP (coop_global_sleepq))
+ {
+ if (QEMPTYP (coop_global_runq))
+ return coop_global_curr;
+ else
+ return coop_qget (&coop_global_runq);
+ }
+
+ if (gnfds > 0)
+ n = safe_select (gnfds, &greadfds, &gwritefds, &gexceptfds, &timeout0);
+ else
+ n = 0;
+ if (QFIRST (coop_global_sleepq)->timeoutp)
+ {
+ gettimeofday (&now, NULL);
+ t = find_thread (n, &now, 0);
+ }
+ else
+ t = find_thread (n, 0, 0);
+ return t == NULL ? coop_global_curr : t;
+}
+
+/* Dirk:Note:: This was externally visible, but only for iselect.c */
+static coop_t *
+coop_wait_for_runnable_thread_now (struct timeval *now)
+{
+ int n;
+ coop_t *t;
+
+ if (gnfds > 0)
+ n = safe_select (gnfds, &greadfds, &gwritefds, &gexceptfds, &timeout0);
+ else
+ n = 0;
+ /* Is there any other runnable thread? */
+ t = find_thread (n, now, 1);
+ while (t == NULL)
+ {
+ /* No. Let the process go to sleep. */
+ if ((t = QFIRST (coop_global_sleepq))->timeoutp)
+ {
+ now->tv_sec = t->wakeup_time.tv_sec - now->tv_sec;
+ if (now->tv_usec > t->wakeup_time.tv_usec)
+ {
+ --now->tv_sec;
+ now->tv_usec = 1000000 + t->wakeup_time.tv_usec - now->tv_usec;
+ }
+ else
+ now->tv_usec = t->wakeup_time.tv_usec - now->tv_usec;
+ n = safe_select (gnfds, &greadfds, &gwritefds, &gexceptfds, now);
+ }
+ else
+ n = safe_select (gnfds, &greadfds, &gwritefds, &gexceptfds, NULL);
+ gettimeofday (now, NULL);
+ t = find_thread (n, now, 1);
+ }
- return s;
+ return t;
}
+
+/* Dirk:Note:: This was externally visible, but only for iselect.c */
+static coop_t *
+coop_wait_for_runnable_thread ()
+{
+ struct timeval now;
-unsigned long
-scm_thread_usleep (unsigned long usec)
+ if (QEMPTYP (coop_global_sleepq))
+ {
+ if (QEMPTYP (coop_global_runq))
+ return coop_global_curr;
+ else
+ return coop_qget (&coop_global_runq);
+ }
+
+ if (QFIRST (coop_global_sleepq)->timeoutp)
+ gettimeofday (&now, NULL);
+
+ return coop_wait_for_runnable_thread_now (&now);
+}
+
+/* Initialize bit counting array */
+static void init_bc (int bit, int i, int n)
+{
+ if (bit == 0)
+ bc[i] = n;
+ else
+ {
+ init_bc (bit >> 1, i, n);
+ init_bc (bit >> 1, i | bit, n + 1);
+ }
+}
+
+static void
+init_iselect ()
{
- /* We're so cheap. */
- scm_thread_sleep (usec / 1000000);
- struct timeval timeout;
- return 0; /* Maybe we should calculate actual time slept,
- but this is faster... :) */
+#if 0 /* This is just symbolic */
+ collisionp = 0;
+ gnfds = 0;
+ FD_ZERO (&greadfds);
+ FD_ZERO (&gwritefds);
+ FD_ZERO (&gexceptfds);
+ timeout0.tv_sec = 0;
+ timeout0.tv_usec = 0;
+#endif
+ init_bc (0x80, 0, 0);
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/iselect.x"
+#endif
}
+
+
+int
+coop_select (int nfds,
+ SELECT_TYPE *readfds,
+ SELECT_TYPE *writefds,
+ SELECT_TYPE *exceptfds,
+ struct timeval *timeout)
+{
+ struct timeval now;
+ coop_t *t, *curr = coop_global_curr;
+
+ /* If the timeout is 0, we're polling and can handle it quickly. */
+ if (timeout != NULL
+ && timeout->tv_sec == 0
+ && timeout->tv_usec == 0)
+ return select (nfds, readfds, writefds, exceptfds, timeout);
+
+ /* Dirk:Note:: Removed call to SCM_DEFER_INTS here. */
+
+ /* Add our file descriptor flags to the common set. */
+ curr->nfds = nfds;
+ curr->readfds = readfds;
+ curr->writefds = writefds;
+ curr->exceptfds = exceptfds;
+ add_fd_sets (curr);
+
+ /* Place ourselves on the sleep queue and get a new thread to run. */
+ if (timeout == NULL)
+ {
+ curr->timeoutp = 0;
+ coop_qput (&coop_global_sleepq, curr);
+ t = coop_wait_for_runnable_thread ();
+ }
+ else
+ {
+ gettimeofday (&now, NULL);
+ curr->timeoutp = 1;
+ curr->wakeup_time.tv_sec = now.tv_sec + timeout->tv_sec;
+ curr->wakeup_time.tv_usec = now.tv_usec + timeout->tv_usec;
+ if (curr->wakeup_time.tv_usec >= 1000000)
+ {
+ ++curr->wakeup_time.tv_sec;
+ curr->wakeup_time.tv_usec -= 1000000;
+ }
+ /* Insert the current thread at the right place in the sleep queue */
+ coop_timeout_qinsert (&coop_global_sleepq, curr);
+ t = coop_wait_for_runnable_thread_now (&now);
+ }
+
+ /* If the new thread is the same as the sleeping thread, do nothing */
+ if (t != coop_global_curr)
+ {
+ /* Do a context switch. */
+ coop_global_curr = t;
+ QT_BLOCK (coop_sleephelp, curr, NULL, t->sp);
+ }
+
+ if (coop_global_curr->retval == -1)
+ errno = coop_global_curr->_errno;
+
+ /* Dirk:Note:: Removed call to SCM_ALLOW_INTS and SCM_ASYNC_TICK here */
+
+ return coop_global_curr->retval;
+}
+
+
+/*****************************************************************************
+Here ends the content of iselect.c:
+*****************************************************************************/
#endif /* GUILE_ISELECT */
Index: libguile/coop.h
===================================================================
RCS file: coop.h
diff -N coop.h
--- /dev/null Tue Feb 13 06:06:23 2001
+++ coop.h Fri Apr 6 21:40:37 2001
@@ -0,0 +1,270 @@
+/* classes: h_files */
+
+#ifndef COOPH
+#define COOPH
+
+/* Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation,
Inc.
+ *
+ * This program 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 2, or (at your option)
+ * any later version.
+ *
+ * This program 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 this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
+ address@hidden, http://www.cs.washington.edu/homes/gjb */
+
+
+#include "libguile/__scm.h"
+
+#include <sys/types.h>
+
+#ifdef TIME_WITH_SYS_TIME
+# include <sys/time.h>
+# include <time.h>
+#else
+# ifdef HAVE_SYS_TIME_H
+# include <sys/time.h>
+# else
+# ifdef HAVE_TIME_H
+# include <time.h>
+# endif
+# endif
+#endif
+
+
+/*****************************************************************************
+Here starts the content of iselect.h:
+*****************************************************************************/
+
+
+#ifdef HAVE_SYS_SELECT_H
+#include <sys/select.h>
+#endif
+
+#ifdef FD_SET
+
+#define SELECT_TYPE fd_set
+#define SELECT_SET_SIZE FD_SETSIZE
+
+#else /* no FD_SET */
+
+/* Define the macros to access a single-int bitmap of descriptors. */
+#define SELECT_SET_SIZE 32
+#define SELECT_TYPE int
+#define FD_SET(n, p) (*(p) |= (1 << (n)))
+#define FD_CLR(n, p) (*(p) &= ~(1 << (n)))
+#define FD_ISSET(n, p) (*(p) & (1 << (n)))
+#define FD_ZERO(p) (*(p) = 0)
+
+#endif /* no FD_SET */
+
+
+/*****************************************************************************
+Here ends the content of iselect.h:
+*****************************************************************************/
+
+
+#ifdef GUILE_PTHREAD_COMPAT
+#include <pthread.h>
+#endif
+
+/* The notion of a thread is merged with the notion of a queue.
+ Thread stuff: thread status (sp) and stuff to use during
+ (re)initialization. Queue stuff: next thread in the queue
+ (next). */
+
+struct qt_t;
+
+typedef struct coop_t {
+ struct qt_t *sp; /* QuickThreads handle. */
+ void *sto; /* `malloc'-allocated stack. */
+
+ struct coop_t *next; /* Next thread in the queue. */
+
+ struct coop_t *all_next;
+ struct coop_t *all_prev;
+
+ void *data; /* Thread local data */
+ void **specific; /* Data associated with keys */
+ int n_keys; /* Upper limit for keys on this thread */
+
+ void *base; /* Base of stack */
+ void *top; /* Top of stack */
+
+ void *joining; /* A queue of threads waiting to join this
+ thread */
+
+#ifdef GUILE_ISELECT
+ int nfds;
+ SELECT_TYPE *readfds;
+ SELECT_TYPE *writefds;
+ SELECT_TYPE *exceptfds;
+ int timeoutp;
+ struct timeval wakeup_time; /* Time to stop sleeping */
+ int _errno;
+ int retval;
+#else
+ time_t wakeup_time; /* Time to stop sleeping */
+#endif
+
+#ifdef GUILE_PTHREAD_COMPAT
+ pthread_t dummy_thread;
+ pthread_mutex_t dummy_mutex;
+#endif
+} coop_t;
+
+extern coop_t coop_global_main; /* Thread for the process. */ /*
FIXME: needed? */
+
+
+/* A queue is a circular list of threads. The queue head is a
+ designated list element. If this is a uniprocessor-only
+ implementation we can store the `main' thread in this, but in a
+ multiprocessor there are several `heavy' threads but only one run
+ queue. A fancier implementation might have private run queues,
+ which would lead to a simpler (trivial) implementation */
+
+typedef struct coop_q_t {
+ coop_t t;
+ coop_t *tail;
+} coop_q_t;
+
+/* A Mutex variable is made up of a owner thread, and a queue of threads
+ waiting on the mutex */
+
+typedef struct coop_m {
+ coop_t *owner; /* Mutex owner */
+ coop_q_t waiting; /* Queue of waiting threads */
+} coop_m;
+
+typedef int coop_mattr;
+
+extern int coop_mutex_init (coop_m*);
+extern int coop_new_mutex_init (coop_m*, coop_mattr*);
+extern int coop_mutex_lock (coop_m*);
+extern int coop_mutex_trylock (coop_m*);
+extern int coop_mutex_unlock (coop_m*);
+extern int coop_mutex_destroy (coop_m*);
+
+/* A Condition variable is made up of a list of threads waiting on the
+ condition. */
+
+typedef struct coop_c {
+ coop_q_t waiting; /* Queue of waiting threads */
+} coop_c;
+
+typedef int coop_cattr;
+
+#ifndef HAVE_STRUCT_TIMESPEC
+/* POSIX.4 structure for a time value. This is like a `struct timeval' but
+ has nanoseconds instead of microseconds. */
+struct timespec
+{
+ long int tv_sec; /* Seconds. */
+ long int tv_nsec; /* Nanoseconds. */
+};
+#endif
+
+extern int coop_condition_variable_init (coop_c*);
+extern int coop_new_condition_variable_init (coop_c*, coop_cattr*);
+extern int coop_condition_variable_wait_mutex (coop_c*, coop_m*);
+extern int coop_condition_variable_timed_wait_mutex (coop_c*,
+ coop_m*,
+ const struct timespec
*abstime);
+extern int coop_condition_variable_signal (coop_c*);
+extern int coop_condition_variable_destroy (coop_c*);
+
+typedef int coop_k;
+
+extern int coop_key_create (coop_k *keyp, void (*destruktor) (void *value));
+extern int coop_setspecific (coop_k key, const void *value);
+extern void *coop_getspecific (coop_k key);
+extern int coop_key_delete (coop_k);
+
+extern void coop_join (coop_t *t);
+extern void coop_yield (void);
+
+
+
+/* Each thread starts by calling a user-supplied function of this
+ type. */
+
+typedef void (coop_userf_t)(void *p0);
+
+/* Call this before any other primitives. */
+extern void coop_init (void);
+
+/* When one or more threads are created by the main thread,
+ the system goes multithread when this is called. It is done
+ (no more runable threads) when this returns. */
+
+extern void coop_start (void);
+
+/* Create a thread and make it runable. When the thread starts
+ running it will call `f' with arguments `p0' and `p1'. */
+
+extern coop_t *coop_create (coop_userf_t *f, void *p0);
+
+/* The current thread stops running but stays runable.
+ It is an error to call `coop_yield' before `coop_start'
+ is called or after `coop_start' returns. */
+
+extern void coop_yield (void);
+extern int coop_select
+ (int nfds, SELECT_TYPE *readfds, SELECT_TYPE *writefds, SELECT_TYPE
*exceptfds, struct timeval *timeout);
+
+/* Like `coop_yield' but the thread is discarded. Any intermediate
+ state is lost. The thread can also terminate by simply
+ returning. */
+
+extern void coop_abort (void);
+
+/* Dirk:Note:: The following are needed(?) in guile-coop.c */
+
+extern coop_q_t coop_global_runq; /* A queue of runable threads. */
+extern coop_q_t coop_global_allq; /* A queue of all threads. */
+extern coop_t *coop_global_curr; /* Currently-executing thread.
*/
+
+extern void coop_all_qput (coop_q_t *q, coop_t *t);
+
+
+#endif /* COOPH */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
Index: libguile/debug-malloc.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/debug-malloc.c,v
retrieving revision 1.8
diff -u -r1.8 debug-malloc.c
--- libguile/debug-malloc.c 2001/03/12 07:08:46 1.8
+++ libguile/debug-malloc.c 2001/04/07 04:40:37
@@ -249,10 +249,10 @@
{
malloc_type = malloc (sizeof (hash_entry_t)
* (malloc_type_size + N_SEEK));
- bzero (malloc_type, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK));
+ memset (malloc_type, 0, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK));
malloc_object = malloc (sizeof (hash_entry_t)
* (malloc_object_size + N_SEEK));
- bzero (malloc_object, sizeof (hash_entry_t) * (malloc_object_size + N_SEEK));
+ memset (malloc_object, 0, sizeof (hash_entry_t) * (malloc_object_size +
N_SEEK));
}
void
Index: libguile/feature.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/feature.c,v
retrieving revision 1.45
diff -u -r1.45 feature.c
--- libguile/feature.c 2001/03/09 23:33:38 1.45
+++ libguile/feature.c 2001/04/07 04:40:37
@@ -122,9 +122,6 @@
#ifndef CHEAP_CONTINUATIONS
scm_add_feature ("full-continuation");
#endif
-#ifdef USE_THREADS
- scm_add_feature ("threads");
-#endif
scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT));
Index: libguile/fluids.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/fluids.c,v
retrieving revision 1.32
diff -u -r1.32 fluids.c
--- libguile/fluids.c 2001/04/03 13:19:04 1.32
+++ libguile/fluids.c 2001/04/07 04:40:37
@@ -107,13 +107,9 @@
next_fluid_num ()
{
int n;
-#ifdef USE_THREADS
SCM_THREAD_CRITICAL_SECTION_START;
-#endif
n = n_fluids++;
-#ifdef USE_THREADS
SCM_THREAD_CRITICAL_SECTION_END;
-#endif
return n;
}
@@ -130,7 +126,6 @@
{
int n;
- SCM_DEFER_INTS;
n = next_fluid_num ();
SCM_RETURN_NEWSMOB (scm_tc16_fluid, n);
}
Index: libguile/gc.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/gc.c,v
retrieving revision 1.191
diff -u -r1.191 gc.c
--- libguile/gc.c 2001/04/03 13:19:04 1.191
+++ libguile/gc.c 2001/04/07 04:40:37
@@ -1001,10 +1001,8 @@
? "*"
: (SCM_NULLP (scm_freelist2) ? "o" : "m"));
#endif
-#ifdef USE_THREADS
/* During the critical section, only the current thread may run. */
SCM_THREAD_CRITICAL_SECTION_START;
-#endif
/* fprintf (stderr, "gc: %s\n", what); */
@@ -1102,9 +1100,7 @@
--scm_gc_heap_lock;
gc_end_stats ();
-#ifdef USE_THREADS
SCM_THREAD_CRITICAL_SECTION_END;
-#endif
scm_c_hook_run (&scm_after_gc_c_hook, 0);
--scm_gc_running_p;
}
Index: libguile/goops.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/goops.c,v
retrieving revision 1.26
diff -u -r1.26 goops.c
--- libguile/goops.c 2001/03/30 02:50:38 1.26
+++ libguile/goops.c 2001/04/07 04:40:37
@@ -1466,7 +1466,7 @@
static int n_hell = 1; /* one place for the evil one himself */
static int hell_size = 4;
#ifdef USE_THREADS
-static scm_mutex_t hell_mutex;
+static SCM hell_mutex;
#endif
static int
@@ -1484,7 +1484,7 @@
{
SCM obj = (SCM) o;
#ifdef USE_THREADS
- scm_mutex_lock (&hell_mutex);
+ scm_mutex_lock (hell_mutex);
#endif
if (n_hell == hell_size)
{
@@ -1494,7 +1494,7 @@
}
hell[n_hell++] = SCM_INST (obj);
#ifdef USE_THREADS
- scm_mutex_unlock (&hell_mutex);
+ scm_mutex_unlock (hell_mutex);
#endif
}
@@ -1502,11 +1502,11 @@
go_to_heaven (void *o)
{
#ifdef USE_THREADS
- scm_mutex_lock (&hell_mutex);
+ scm_mutex_lock (hell_mutex);
#endif
hell[burnin ((SCM) o)] = hell[--n_hell];
#ifdef USE_THREADS
- scm_mutex_unlock (&hell_mutex);
+ scm_mutex_unlock (hell_mutex);
#endif
}
@@ -2673,7 +2673,8 @@
hell = scm_must_malloc (hell_size, "hell");
#ifdef USE_THREADS
- scm_mutex_init (&hell_mutex);
+ hell_mutex = scm_make_mutex ();
+ scm_protect_object (hell_mutex);
#endif
create_basic_classes ();
Index: libguile/guile-coop.c
===================================================================
RCS file: guile-coop.c
diff -N guile-coop.c
--- /dev/null Tue Feb 13 06:06:23 2001
+++ guile-coop.c Fri Apr 6 21:40:37 2001
@@ -0,0 +1,419 @@
+/* Copyright (C) 2000 Free Software Foundation, Inc.
+ *
+ * This program 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 2, or (at your option)
+ * any later version.
+ *
+ * This program 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 this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+
+#include "libguile/coop.h"
+#include "libguile/_scm.h"
+#include "libguile/feature.h"
+#include "libguile/root.h"
+#include "libguile/threads.h"
+#include "libguile/guile-coop.h"
+#include "libguile/validate.h"
+#include "libguile/gc.h"
+
+
+
+/* Thread functions */
+
+static scm_thread_t
+make_thread (scm_threadattr_t * attr, void * (*start_routine) (void *), void *
arg)
+{
+ /* FIXME: bad cast to coop_userf_t */
+ return (scm_thread_t) coop_create ((coop_userf_t *) start_routine, arg);
+}
+
+
+static void
+thread_exit (void * retval)
+{
+ coop_abort ();
+}
+
+
+static int
+thread_cancel (scm_thread_t thread)
+{
+ scm_misc_error ("guile-coop.c:thread_cancel", "Not implemented yet.",
SCM_EOL);
+}
+
+static int
+thread_join (scm_thread_t thread, void ** retval)
+{
+ coop_t *thread_data;
+ /* Dirk:FIXME:: SCM_THREAD_DATA is a handle for a thread. It may be that a
+ * certain thread implementation uses a value of 0 as a valid thread handle.
+ * With the following code, this thread would always be considered finished.
+ */
+ /* Dirk:FIXME:: With preemptive threading, a thread may finish immediately
+ * after SCM_THREAD_DATA is read. Thus, it must be guaranteed that the
+ * handle remains valid until the thread-object is garbage collected, or
+ * a mutex has to be used for reading and modifying SCM_THREAD_DATA.
+ */
+ thread_data = (coop_t *)SCM_THREAD_DATA (thread);
+ if (thread_data)
+ /* The thread is still alive */
+ coop_join (thread_data);
+ return 0;
+}
+
+
+static size_t
+thread_free (scm_thread_t thread)
+{
+ return 0;
+}
+
+
+
+/* Cooperative functions */
+
+static void
+thread_yield (void)
+{
+ coop_yield ();
+}
+
+
+static int
+thread_select (int f, SELECT_TYPE * r, SELECT_TYPE * w, SELECT_TYPE * e,
struct timeval *t)
+{
+ return coop_select (f, r, w, e, t);
+}
+
+
+
+/* Mutex functions */
+
+static scm_mutex_t *
+make_mutex (const scm_mutexattr_t * mutexattr)
+{
+ coop_m * data = (coop_m *) scm_must_malloc (sizeof (coop_m), "mutex");
+ coop_mutex_init (data);
+ return (scm_mutex_t *) data;
+}
+
+
+static int
+mutex_lock (scm_mutex_t * mutex)
+{
+ return coop_mutex_lock ((coop_m *) mutex);
+}
+
+
+static int
+mutex_trylock (scm_mutex_t * mutex)
+{
+ return coop_mutex_trylock ((coop_m *) mutex);
+}
+
+
+static int
+mutex_unlock (scm_mutex_t * mutex)
+{
+ return coop_mutex_unlock ((coop_m *) mutex);
+}
+
+
+static size_t
+mutex_free (scm_mutex_t * mutex)
+{
+ coop_mutex_destroy ((coop_m *) mutex);
+ scm_must_free ((coop_m *) mutex);
+ return sizeof (coop_m);
+}
+
+
+
+/* Condition variable functions */
+
+static scm_cond_t *
+make_cond (const scm_condattr_t * cond_attr)
+{
+ coop_c * data = (coop_c *) scm_must_malloc (sizeof (coop_c), "condvar");
+ coop_condition_variable_init (data);
+ return (scm_cond_t *) data;
+}
+
+
+static int
+cond_signal (scm_cond_t * cond)
+{
+ return coop_condition_variable_signal ((coop_c *) cond);
+}
+
+
+static int
+cond_broadcast (scm_cond_t * cond)
+{
+ scm_misc_error ("guile-coop.c:cond_broadcast", "Not implemented yet.",
SCM_EOL);
+}
+
+
+static int
+cond_wait (scm_cond_t * cond, scm_mutex_t * mutex)
+{
+ return coop_condition_variable_wait_mutex ((coop_c *) cond, (coop_m *)
mutex);
+}
+
+
+static int
+cond_timedwait (scm_cond_t * cond, scm_mutex_t * mutex, const struct timespec
* abstime)
+{
+ return coop_condition_variable_timed_wait_mutex ((coop_c *) cond, (coop_m *)
mutex, abstime);
+}
+
+
+static size_t
+cond_free (scm_cond_t * cond)
+{
+ coop_condition_variable_destroy ((coop_c *) cond);
+ scm_must_free ((coop_c *) cond);
+ return sizeof (coop_c);
+}
+
+
+
+/* Key functions */
+
+static int
+key_create (scm_key_t * key, void (*destr_function) (void *))
+{
+ return coop_key_create ((coop_k *) key, destr_function);
+}
+
+
+static int
+key_delete (scm_key_t key)
+{
+ return coop_key_delete ((coop_k) key);
+}
+
+
+
+/* Functions for thread specific data */
+
+static int
+set_thread_specific_data (scm_key_t key, const void * data)
+{
+ return coop_setspecific ((coop_k) key, data);
+}
+
+
+static void *
+thread_specific_data (scm_key_t key)
+{
+ return coop_getspecific ((coop_k) key);
+}
+
+
+static void
+set_thread_local_data (void * data)
+{
+ coop_global_curr->data = data;
+}
+
+
+static void *
+thread_local_data (void)
+{
+ return coop_global_curr->data;
+}
+
+
+
+/* Garbage collection functions */
+
+static void
+threads_mark_stacks (void)
+{
+ coop_t *thread;
+
+ for (thread = coop_global_allq.t.all_next;
+ thread != NULL; thread = thread->all_next)
+ {
+ if (thread == coop_global_curr)
+ {
+ /* Active thread */
+ /* stack_len is long rather than sizet in order to guarantee
+ that &stack_len is long aligned */
+#ifdef STACK_GROWS_UP
+ long stack_len = ((SCM_STACKITEM *) (&thread) -
+ (SCM_STACKITEM *) thread->base);
+
+ /* Protect from the C stack. This must be the first marking
+ * done because it provides information about what objects
+ * are "in-use" by the C code. "in-use" objects are those
+ * for which the information about length and base address must
+ * remain usable. This requirement is stricter than a liveness
+ * requirement -- in particular, it constrains the implementation
+ * of scm_resizuve.
+ */
+ SCM_FLUSH_REGISTER_WINDOWS;
+ /* This assumes that all registers are saved into the jmp_buf */
+ setjmp (scm_save_regs_gc_mark);
+ scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
+ ((scm_sizet) sizeof scm_save_regs_gc_mark
+ / sizeof (SCM_STACKITEM)));
+
+ scm_mark_locations (((size_t) thread->base,
+ (sizet) stack_len));
+#else
+ long stack_len = ((SCM_STACKITEM *) thread->base -
+ (SCM_STACKITEM *) (&thread));
+
+ /* Protect from the C stack. This must be the first marking
+ * done because it provides information about what objects
+ * are "in-use" by the C code. "in-use" objects are those
+ * for which the values from SCM_LENGTH and SCM_CHARS must remain
+ * usable. This requirement is stricter than a liveness
+ * requirement -- in particular, it constrains the implementation
+ * of scm_resizuve.
+ */
+ SCM_FLUSH_REGISTER_WINDOWS;
+ /* This assumes that all registers are saved into the jmp_buf */
+ setjmp (scm_save_regs_gc_mark);
+ scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
+ ((scm_sizet) sizeof scm_save_regs_gc_mark
+ / sizeof (SCM_STACKITEM)));
+
+ scm_mark_locations ((SCM_STACKITEM *) &thread,
+ stack_len);
+#endif
+ }
+ else
+ {
+ /* Suspended thread */
+#ifdef STACK_GROWS_UP
+ long stack_len = ((SCM_STACKITEM *) (thread->sp) -
+ (SCM_STACKITEM *) thread->base);
+
+ scm_mark_locations ((size_t)thread->base,
+ (sizet) stack_len);
+#else
+ long stack_len = ((SCM_STACKITEM *) thread->base -
+ (SCM_STACKITEM *) (thread->sp));
+
+ /* Registers are already on the stack. No need to mark. */
+
+ scm_mark_locations ((SCM_STACKITEM *) (size_t)thread->sp,
+ stack_len);
+#endif
+ }
+
+ /* Mark this thread's root */
+ scm_gc_mark (((scm_root_state *) thread->data) -> handle);
+ }
+}
+
+
+
+/* Functions to set parameters */
+
+static void
+set_threads_stack_size (size_t size)
+{
+ scm_misc_error ("guile-coop.c:set_threads_stack_size", "Not implemented
yet.", SCM_EOL);
+}
+
+
+/* Initialization */
+
+void
+scm_threads_init (void)
+{
+ SCM_STACKITEM *base = (SCM_STACKITEM *)scm_get_stack_base ();
+
+ coop_init();
+
+ scm_thread_count = 1;
+
+#ifndef GUILE_PTHREAD_COMPAT
+ coop_global_main.sto = base;
+#endif
+ coop_global_main.base = base;
+ coop_global_curr = &coop_global_main;
+ coop_all_qput (&coop_global_allq, coop_global_curr);
+ coop_global_main.data = 0; /* Initialized in init.c */
+
+
+ scm_thread.make_thread = make_thread;
+ scm_thread.thread_exit = thread_exit;
+ scm_thread.thread_cancel = thread_cancel;
+ scm_thread.thread_join = thread_join;
+ scm_thread.thread_free = thread_free;
+
+ scm_thread.thread_yield = thread_yield;
+ scm_thread.thread_select = thread_select;
+
+ scm_thread.make_mutex = make_mutex;
+ scm_thread.mutex_lock = mutex_lock;
+ scm_thread.mutex_trylock = mutex_trylock;
+ scm_thread.mutex_unlock = mutex_unlock;
+ scm_thread.mutex_free = mutex_free;
+
+ scm_thread.make_cond = make_cond;
+ scm_thread.cond_signal = cond_signal;
+ scm_thread.cond_broadcast = cond_broadcast;
+ scm_thread.cond_wait = cond_wait;
+ scm_thread.cond_timedwait = cond_timedwait;
+ scm_thread.cond_free = cond_free;
+
+ scm_thread.key_create = key_create;
+ scm_thread.key_delete = key_delete;
+
+ scm_thread.set_thread_specific_data = set_thread_specific_data;
+ scm_thread.thread_specific_data = thread_specific_data;
+ scm_thread.set_thread_local_data = set_thread_local_data;
+ scm_thread.thread_local_data = thread_local_data;
+
+ scm_thread.threads_mark_stacks = threads_mark_stacks;
+
+ scm_thread.set_threads_stack_size = set_threads_stack_size;
+
+ scm_add_feature ("coop-threads");
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
Index: libguile/guile-coop.h
===================================================================
RCS file: guile-coop.h
diff -N guile-coop.h
--- /dev/null Tue Feb 13 06:06:23 2001
+++ guile-coop.h Fri Apr 6 21:40:37 2001
@@ -0,0 +1,60 @@
+/* classes: h_files */
+
+#ifndef GUILECOOPH
+#define GUILECOOPH
+
+/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+ *
+ * This program 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 2, or (at your option)
+ * any later version.
+ *
+ * This program 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 this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+
+#include "libguile/__scm.h"
+
+
+
+extern void scm_threads_init (void);
+
+#endif /* GUILECOOPH */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
Index: libguile/init.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/init.c,v
retrieving revision 1.115
diff -u -r1.115 init.c
--- libguile/init.c 2001/03/30 02:50:38 1.115
+++ libguile/init.c 2001/04/07 04:40:38
@@ -83,9 +83,6 @@
#include "libguile/hash.h"
#include "libguile/hashtab.h"
#include "libguile/hooks.h"
-#ifdef GUILE_ISELECT
-#include "libguile/iselect.h"
-#endif
#include "libguile/ioext.h"
#include "libguile/keywords.h"
#include "libguile/lang.h"
@@ -476,10 +473,6 @@
scm_environments_prehistory (); /* requires storage */
scm_init_continuations ();
scm_init_root (); /* requires continuations */
-#ifdef USE_THREADS
- scm_init_threads (base);
-#endif
- start_stack (base);
scm_init_gsubr ();
scm_init_procprop ();
scm_init_environments ();
@@ -489,6 +482,11 @@
scm_init_async ();
scm_init_boolean ();
scm_init_chars ();
+ scm_init_dynamic_linking ();
+#ifdef USE_THREADS
+ scm_init_threads (); /* requires dynamic_linking, gsubr, feature */
+#endif
+ start_stack (base); /* requires threads */
#ifdef GUILE_DEBUG_MALLOC
scm_init_debug_malloc ();
#endif
@@ -506,9 +504,6 @@
scm_init_properties ();
scm_init_hooks (); /* Requires objprop until hook names are removed */
scm_init_gc (); /* Requires hooks, async */
-#ifdef GUILE_ISELECT
- scm_init_iselect ();
-#endif
scm_init_ioext ();
scm_init_keywords ();
scm_init_list ();
@@ -570,7 +565,6 @@
scm_init_simpos ();
scm_init_load_path ();
scm_init_standard_ports (); /* Requires fports */
- scm_init_dynamic_linking ();
scm_init_lang ();
scm_init_script ();
Index: libguile/iselect.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/iselect.c,v
retrieving revision 1.27
diff -u -r1.27 iselect.c
--- libguile/iselect.c 2001/03/10 16:56:06 1.27
+++ libguile/iselect.c 2001/04/07 04:40:38
@@ -39,602 +39,16 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
-#include <stdio.h>
-#include <errno.h>
-#include <limits.h>
-#include <string.h>
-
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#include "libguile/_scm.h"
#include "libguile/async.h"
-
+#include "libguile/threads.h"
#include "libguile/iselect.h"
-#ifdef GUILE_ISELECT
-
-#include "libguile/coop-threads.h"
-
-#ifdef MISSING_BZERO_DECL
-extern void bzero (void *, size_t);
-#endif
-
-
-/* COOP queue macros */
-#define QEMPTYP(q) (q.t.next == &q.t)
-#define QFIRST(q) (q.t.next)
-
-/* These macros count the number of bits in a word. */
-#define SCM_BITS_PER_LONG (8 * sizeof (unsigned long))
-/* Use LONG_MAX instead of ULONG_MAX here since not all systems define
- ULONG_MAX */
-#if LONG_MAX >> 16 == 0
-#define SCM_NLONGBITS(p) (bc[((unsigned char *)(p))[0]]\
- + bc[((unsigned char *)(p))[1]])
-#elif LONG_MAX >> 32 == 0 || LONG_MAX == 2147483647L /* bug in Sun CC 4.2 */
-#define SCM_NLONGBITS(p) (bc[((unsigned char *)(p))[0]]\
- + bc[((unsigned char *)(p))[1]]\
- + bc[((unsigned char *)(p))[2]]\
- + bc[((unsigned char *)(p))[3]])
-#elif LONG_MAX >> 64 == 0
-#define SCM_NLONGBITS(p) (bc[((unsigned char *)(p))[0]]\
- + bc[((unsigned char *)(p))[1]]\
- + bc[((unsigned char *)(p))[2]]\
- + bc[((unsigned char *)(p))[3]]\
- + bc[((unsigned char *)(p))[4]]\
- + bc[((unsigned char *)(p))[5]]\
- + bc[((unsigned char *)(p))[6]]\
- + bc[((unsigned char *)(p))[7]])
-#else
-#error Could not determine suitable definition for SCM_NLONGBITS
-#endif
-
-#ifdef HAVE_BZERO
-#define FD_ZERO_N(pos, n) bzero ((pos), (n))
-#else
-#define FD_ZERO_N(pos, n) memset ((void *) (pos), 0, (n))
-#endif
-
-typedef unsigned long *ulongptr;
-
-static char bc[256]; /* Bit counting array. bc[x] is the number of
- bits in x. */
-
-int scm_I_am_dead;
-
-/* This flag indicates that several threads are waiting on the same
- file descriptor. When this is the case, the common fd sets are
- updated in a more inefficient way. */
-int collisionp;
-
-/* These are the common fd sets. When new select calls are made,
- those sets are merged into these. */
-int gnfds;
-SELECT_TYPE greadfds;
-SELECT_TYPE gwritefds;
-SELECT_TYPE gexceptfds;
-
-/* These are the result sets. They are used when we call OS select.
- We couldn't use the common fd sets above, since that would destroy
- them. */
-SELECT_TYPE rreadfds;
-SELECT_TYPE rwritefds;
-SELECT_TYPE rexceptfds;
-
-/* Constant timeval struct representing a zero timeout which we use
- when polling. */
-static struct timeval timeout0;
-
-/* As select, but doesn't destroy the file descriptor sets passed as
- arguments. The results are stored into the result sets. */
-static int
-safe_select (int nfds,
- SELECT_TYPE *readfds,
- SELECT_TYPE *writefds,
- SELECT_TYPE *exceptfds,
- struct timeval *timeout)
-{
- int n = (nfds + 7) / 8;
- /* Copy file descriptor sets to result area */
- if (readfds == NULL)
- FD_ZERO (&rreadfds);
- else
- {
- memcpy (&rreadfds, readfds, n);
- FD_ZERO_N ((char *) &rreadfds + n, SELECT_SET_SIZE / 8 - n);
- }
- if (writefds == NULL)
- FD_ZERO (&rwritefds);
- else
- {
- memcpy (&rwritefds, writefds, n);
- FD_ZERO_N ((char *) &rwritefds + n, SELECT_SET_SIZE / 8 - n);
- }
- if (exceptfds == NULL)
- FD_ZERO (&rexceptfds);
- else
- {
- memcpy (&rexceptfds, exceptfds, n);
- FD_ZERO_N ((char *) &rexceptfds + n, SELECT_SET_SIZE / 8 - n);
- }
- return select (nfds, &rreadfds, &rwritefds, &rexceptfds, timeout);
-}
-
-/* Merge new file descriptor sets into the common sets. */
-static void
-add_fd_sets (coop_t *t)
-{
- int n = (t->nfds + SCM_BITS_PER_LONG - 1) / SCM_BITS_PER_LONG;
- int i;
-
- /* Detect if the fd sets of the thread have any bits in common with
- the rest of the waiting threads. If that is so, set the
- collision flag. This causes a more time consuming handling of
- the common fd sets---they need to recalculated every time a
- thread wakes up. */
- if (!collisionp)
- for (i = 0; i < n; ++i)
- if ((t->readfds != NULL
- && (((ulongptr) t->readfds)[i] & ((ulongptr) &greadfds)[i]) != 0)
- || (t->writefds != NULL
- && ((((ulongptr) t->writefds)[i] & ((ulongptr) &gwritefds)[i])
- != 0))
- || (t->exceptfds != NULL
- && ((((ulongptr) t->exceptfds)[i] & ((ulongptr) &gexceptfds)[i])
- != 0)))
- {
- collisionp = 1;
- break;
- }
-
- /* We recalculate nfds below. The cost for this can be paid back
- with a great bonus since many programs are lazy with the nfds
- arg. Many even pass 1024 when using one of the lowest fd:s!
-
- We approach from above, checking for non-zero bits. As soon as
- we have determined the value of nfds, we jump down to code below
- which concludes the updating of the common sets. */
- t->nfds = 0;
- i = n;
- while (i > 0)
- {
- --i;
- if (t->readfds != NULL && ((ulongptr) t->readfds)[i] != 0)
- {
- ((ulongptr) &greadfds)[i] |= ((ulongptr) t->readfds)[i];
- n = (i + 1) * SCM_BITS_PER_LONG;
- t->nfds = n;
- if (n > gnfds)
- gnfds = n;
- goto cont_read;
- }
- if (t->writefds != NULL && ((ulongptr) t->writefds)[i] != 0)
- {
- ((ulongptr) &gwritefds)[i] |= ((ulongptr) t->writefds)[i];
- n = (i + 1) * SCM_BITS_PER_LONG;
- t->nfds = n;
- if (n > gnfds)
- gnfds = n;
- goto cont_write;
- }
- if (t->exceptfds != NULL && ((ulongptr) t->exceptfds)[i] != 0)
- {
- ((ulongptr) &gexceptfds)[i] |= ((ulongptr) t->exceptfds)[i];
- n = (i + 1) * SCM_BITS_PER_LONG;
- t->nfds = n;
- if (n > gnfds)
- gnfds = n;
- goto cont_except;
- }
- }
- return;
-
- /* nfds is now determined. Just finish updating the common sets. */
- while (i > 0)
- {
- --i;
- if (t->readfds != NULL && ((ulongptr) t->readfds)[i] != 0)
- ((ulongptr) &greadfds)[i] |= ((ulongptr) t->readfds)[i];
- cont_read:
- if (t->writefds != NULL && ((ulongptr) t->writefds)[i] != 0)
- ((ulongptr) &gwritefds)[i] |= ((ulongptr) t->writefds)[i];
- cont_write:
- if (t->exceptfds != NULL && ((ulongptr) t->exceptfds)[i] != 0)
- ((ulongptr) &gexceptfds)[i] |= ((ulongptr) t->exceptfds)[i];
- cont_except:
- ;
- }
-}
-
-/* Update the fd sets pointed to by the thread so that they reflect
- the status of the file descriptors which the thread was interested
- in. Also clear those bits in the common sets. This function is
- only called when there are no bit collisions. */
-static void
-finalize_fd_sets (coop_t *t)
-{
- int i = (t->nfds + SCM_BITS_PER_LONG - 1) / SCM_BITS_PER_LONG;
- int n_ones = 0;
- register unsigned long s;
-
- if (t->nfds == gnfds)
- {
- /* This thread is the one responsible for the current high value
- of gnfds. First do our other jobs while at the same time
- trying to decrease gnfds. */
- while (i > 0)
- {
- --i;
- if (t->readfds != NULL && (s = ((ulongptr) t->readfds)[i]) != 0)
- {
- ((ulongptr) t->readfds)[i] &= ((ulongptr) &rreadfds)[i];
- ((ulongptr) &greadfds)[i] &= ~s;
- n_ones += SCM_NLONGBITS (&((ulongptr) t->readfds)[i]);
- }
- if (((ulongptr) &greadfds)[i] != 0)
- {
- gnfds = (i + 1) * SCM_BITS_PER_LONG;
- goto cont_read;
- }
- if (t->writefds != NULL && (s = ((ulongptr) t->writefds)[i]) != 0)
- {
- ((ulongptr) t->writefds)[i] &= ((ulongptr) &rwritefds)[i];
- ((ulongptr) &gwritefds)[i] &= ~s;
- n_ones += SCM_NLONGBITS (&((ulongptr) t->writefds)[i]);
- }
- if (((ulongptr) &gwritefds)[i] != 0)
- {
- gnfds = (i + 1) * SCM_BITS_PER_LONG;
- goto cont_write;
- }
- if (t->exceptfds != NULL && (s = ((ulongptr) t->exceptfds)[i]) != 0)
- {
- ((ulongptr) t->exceptfds)[i] &= ((ulongptr) &rexceptfds)[i];
- ((ulongptr) &gexceptfds)[i] &= ~s;
- n_ones += SCM_NLONGBITS (&((ulongptr) t->exceptfds)[i]);
- }
- if (((ulongptr) &gexceptfds)[i] != 0)
- {
- gnfds = (i + 1) * SCM_BITS_PER_LONG;
- goto cont_except;
- }
- }
- gnfds = 0;
- t->retval = n_ones;
- return;
- }
-
- /* Either this thread wasn't responsible for gnfds or gnfds has been
- determined. */
- while (i > 0)
- {
- --i;
- if (t->readfds != NULL && (s = ((ulongptr) t->readfds)[i]) != 0)
- {
- ((ulongptr) t->readfds)[i] &= ((ulongptr) &rreadfds)[i];
- ((ulongptr) &greadfds)[i] &= ~s;
- n_ones += SCM_NLONGBITS (&((ulongptr) t->readfds)[i]);
- }
- cont_read:
- if (t->writefds != NULL && (s = ((ulongptr) t->writefds)[i]) != 0)
- {
- ((ulongptr) t->writefds)[i] &= ((ulongptr) &rwritefds)[i];
- ((ulongptr) &gwritefds)[i] &= ~s;
- n_ones += SCM_NLONGBITS (&((ulongptr) t->writefds)[i]);
- }
- cont_write:
- if (t->exceptfds != NULL && (s = ((ulongptr) t->exceptfds)[i]) != 0)
- {
- ((ulongptr) t->exceptfds)[i] &= ((ulongptr) &rexceptfds)[i];
- ((ulongptr) &gexceptfds)[i] &= ~s;
- n_ones += SCM_NLONGBITS (&((ulongptr) t->exceptfds)[i]);
- }
- cont_except:
- ;
- }
- t->retval = n_ones;
-}
-
-/* Just like finalize_fd_sets except that we don't have to update the
- global fd sets. Those will be recalulated elsewhere. */
-static void
-finalize_fd_sets_lazily (coop_t *t)
-{
- int i = (t->nfds + SCM_BITS_PER_LONG - 1) / SCM_BITS_PER_LONG;
- int n_ones = 0;
- while (i > 0)
- {
- --i;
- if (t->readfds != NULL && ((ulongptr) t->readfds)[i] != 0)
- {
- ((ulongptr) t->readfds)[i] &= ((ulongptr) &rreadfds)[i];
- n_ones += SCM_NLONGBITS (&((ulongptr) t->readfds)[i]);
- }
- if (t->writefds != NULL && ((ulongptr) t->writefds)[i] != 0)
- {
- ((ulongptr) t->writefds)[i] &= ((ulongptr) &rwritefds)[i];
- n_ones += SCM_NLONGBITS (&((ulongptr) t->writefds)[i]);
- }
- if (t->exceptfds != NULL && ((ulongptr) t->exceptfds)[i] != 0)
- {
- ((ulongptr) t->exceptfds)[i] &= ((ulongptr) &rexceptfds)[i];
- n_ones += SCM_NLONGBITS (&((ulongptr) t->exceptfds)[i]);
- }
- }
- t->retval = n_ones;
-}
-
-/* Return first fd with a non-zero bit in any of the result sets. */
-static int
-first_interesting_fd (void)
-{
- int i = 0;
- SELECT_TYPE *s;
- while (1)
- {
- if (((ulongptr) &rreadfds)[i] != 0)
- {
- s = &rreadfds;
- break;
- }
- if (((ulongptr) &rwritefds)[i] != 0)
- {
- s = &rwritefds;
- break;
- }
- if (((ulongptr) &rexceptfds)[i] != 0)
- {
- s = &rexceptfds;
- break;
- }
- ++i;
- }
- i *= SCM_BITS_PER_LONG;
- while (i < gnfds)
- {
- if (FD_ISSET (i, s))
- return i;
- ++i;
- }
- fprintf (stderr, "first_interesting_fd: internal error\n");
- exit (1);
-}
-
-/* Revive all threads with an error status. */
-void
-scm_error_revive_threads (void)
-{
- coop_t *t;
-
- while ((t = coop_qget (&coop_global_sleepq)) != NULL)
- {
- t->_errno = errno;
- t->retval = -1;
- if (t != coop_global_curr)
- coop_qput (&coop_global_runq, t);
- }
- collisionp = 0;
- gnfds = 0;
- FD_ZERO (&greadfds);
- FD_ZERO (&gwritefds);
- FD_ZERO (&gexceptfds);
-}
-
-/* Given the result of a call to safe_select and the current time,
- try to wake up some threads and return the first one. Return NULL
- if we couldn't find any. */
-static coop_t *
-find_thread (int n, struct timeval *now, int sleepingp)
-{
- coop_t *t;
- int fd;
-
- if (n < 0)
- /* An error or a signal has occured. Wake all threads. Since we
- don't care to calculate if there is a sinner we report the
- error to all of them. */
- {
- scm_error_revive_threads ();
- if (!scm_I_am_dead)
- return coop_global_curr;
- }
- else if (n == 0)
- {
- while (!QEMPTYP (coop_global_sleepq)
- && (t = QFIRST (coop_global_sleepq))->timeoutp
- && (t->wakeup_time.tv_sec < now->tv_sec
- || (t->wakeup_time.tv_sec == now->tv_sec
- && t->wakeup_time.tv_usec <= now->tv_usec)))
- {
- coop_qget (&coop_global_sleepq);
- if (collisionp)
- finalize_fd_sets_lazily (t);
- else
- finalize_fd_sets (t);
- coop_qput (&coop_global_runq, t);
- }
- if (collisionp)
- {
- while ((t = coop_qget (&coop_global_sleepq)) != NULL)
- coop_qput (&coop_tmp_queue, t);
- goto rebuild_global_fd_sets;
- }
- }
- else if (n > 0)
- {
- /* Find the first interesting file descriptor */
- fd = first_interesting_fd ();
- /* Check the sleeping queue for this file descriptor.
- Other file descriptors will be handled next time
- coop_next_runnable_thread is called. */
- /* This code is inefficient. We'll improve it later. */
- while ((t = coop_qget (&coop_global_sleepq)) != NULL)
- {
- if ((t->readfds && FD_ISSET (fd, t->readfds))
- || (t->writefds && FD_ISSET (fd, t->writefds))
- || (t->exceptfds && FD_ISSET (fd, t->exceptfds))
- || (t->timeoutp
- && (t->wakeup_time.tv_sec < now->tv_sec
- || (t->wakeup_time.tv_sec == now->tv_sec
- && t->wakeup_time.tv_usec <= now->tv_usec))))
- {
- if (collisionp)
- finalize_fd_sets_lazily (t);
- else
- finalize_fd_sets (t);
- coop_qput (&coop_global_runq, t);
- }
- else
- coop_qput(&coop_tmp_queue, t);
- }
- if (collisionp)
- {
- rebuild_global_fd_sets:
- collisionp = 0;
- gnfds = 0;
- FD_ZERO (&greadfds);
- FD_ZERO (&gwritefds);
- FD_ZERO (&gexceptfds);
- while ((t = coop_qget (&coop_tmp_queue)) != NULL)
- {
- add_fd_sets (t);
- coop_qput (&coop_global_sleepq, t);
- }
- }
- else
- {
- while ((t = coop_qget (&coop_tmp_queue)) != NULL)
- coop_qput (&coop_global_sleepq, t);
- }
- }
-
- return coop_qget (&coop_global_runq);
-}
-
-/* Return next runnable thread on the run queue.
- * First update the queue with possible I/O or timeouts.
- * If no thread is found, return NULL.
- */
-coop_t *
-coop_next_runnable_thread ()
-{
- coop_t *t;
- struct timeval now;
- int n;
-
- /* Just return next thread on the runq if the sleepq is empty. */
- if (QEMPTYP (coop_global_sleepq))
- {
- if (QEMPTYP (coop_global_runq))
- return coop_global_curr;
- else
- return coop_qget (&coop_global_runq);
- }
-
- if (gnfds > 0)
- n = safe_select (gnfds, &greadfds, &gwritefds, &gexceptfds, &timeout0);
- else
- n = 0;
- if (QFIRST (coop_global_sleepq)->timeoutp)
- {
- gettimeofday (&now, NULL);
- t = find_thread (n, &now, 0);
- }
- else
- t = find_thread (n, 0, 0);
- return t == NULL ? coop_global_curr : t;
-}
-
-coop_t *
-coop_wait_for_runnable_thread_now (struct timeval *now)
-{
- int n;
- coop_t *t;
-
- if (gnfds > 0)
- n = safe_select (gnfds, &greadfds, &gwritefds, &gexceptfds, &timeout0);
- else
- n = 0;
- /* Is there any other runnable thread? */
- t = find_thread (n, now, 1);
- while (t == NULL)
- {
- /* No. Let the process go to sleep. */
- if ((t = QFIRST (coop_global_sleepq))->timeoutp)
- {
- now->tv_sec = t->wakeup_time.tv_sec - now->tv_sec;
- if (now->tv_usec > t->wakeup_time.tv_usec)
- {
- --now->tv_sec;
- now->tv_usec = 1000000 + t->wakeup_time.tv_usec - now->tv_usec;
- }
- else
- now->tv_usec = t->wakeup_time.tv_usec - now->tv_usec;
- n = safe_select (gnfds, &greadfds, &gwritefds, &gexceptfds, now);
- }
- else
- n = safe_select (gnfds, &greadfds, &gwritefds, &gexceptfds, NULL);
- gettimeofday (now, NULL);
- t = find_thread (n, now, 1);
- }
-
- return t;
-}
-
-coop_t *
-coop_wait_for_runnable_thread ()
-{
- struct timeval now;
-
- if (QEMPTYP (coop_global_sleepq))
- {
- if (QEMPTYP (coop_global_runq))
- return coop_global_curr;
- else
- return coop_qget (&coop_global_runq);
- }
-
- if (QFIRST (coop_global_sleepq)->timeoutp)
- gettimeofday (&now, NULL);
-
- return coop_wait_for_runnable_thread_now (&now);
-}
-
-/* Initialize bit counting array */
-static void init_bc (int bit, int i, int n)
-{
- if (bit == 0)
- bc[i] = n;
- else
- {
- init_bc (bit >> 1, i, n);
- init_bc (bit >> 1, i | bit, n + 1);
- }
-}
-
-void
-scm_init_iselect ()
-{
-#if 0 /* This is just symbolic */
- collisionp = 0;
- gnfds = 0;
- FD_ZERO (&greadfds);
- FD_ZERO (&gwritefds);
- FD_ZERO (&gexceptfds);
- timeout0.tv_sec = 0;
- timeout0.tv_usec = 0;
-#endif
- init_bc (0x80, 0, 0);
-#ifndef SCM_MAGIC_SNARFER
-#include "libguile/iselect.x"
-#endif
-}
-
-#endif /* GUILE_ISELECT */
-
int
scm_internal_select (int nfds,
SELECT_TYPE *readfds,
@@ -644,64 +58,11 @@
{
#ifndef GUILE_ISELECT
int res = select (nfds, readfds, writefds, exceptfds, timeout);
- SCM_ASYNC_TICK;
- return res;
#else /* GUILE_ISELECT */
- struct timeval now;
- coop_t *t, *curr = coop_global_curr;
-
- /* If the timeout is 0, we're polling and can handle it quickly. */
- if (timeout != NULL
- && timeout->tv_sec == 0
- && timeout->tv_usec == 0)
- return select (nfds, readfds, writefds, exceptfds, timeout);
-
- SCM_DEFER_INTS;
-
- /* Add our file descriptor flags to the common set. */
- curr->nfds = nfds;
- curr->readfds = readfds;
- curr->writefds = writefds;
- curr->exceptfds = exceptfds;
- add_fd_sets (curr);
-
- /* Place ourselves on the sleep queue and get a new thread to run. */
- if (timeout == NULL)
- {
- curr->timeoutp = 0;
- coop_qput (&coop_global_sleepq, curr);
- t = coop_wait_for_runnable_thread ();
- }
- else
- {
- gettimeofday (&now, NULL);
- curr->timeoutp = 1;
- curr->wakeup_time.tv_sec = now.tv_sec + timeout->tv_sec;
- curr->wakeup_time.tv_usec = now.tv_usec + timeout->tv_usec;
- if (curr->wakeup_time.tv_usec >= 1000000)
- {
- ++curr->wakeup_time.tv_sec;
- curr->wakeup_time.tv_usec -= 1000000;
- }
- /* Insert the current thread at the right place in the sleep queue */
- coop_timeout_qinsert (&coop_global_sleepq, curr);
- t = coop_wait_for_runnable_thread_now (&now);
- }
-
- /* If the new thread is the same as the sleeping thread, do nothing */
- if (t != coop_global_curr)
- {
- /* Do a context switch. */
- coop_global_curr = t;
- QT_BLOCK (coop_sleephelp, curr, NULL, t->sp);
- }
-
- if (coop_global_curr->retval == -1)
- errno = coop_global_curr->_errno;
- SCM_ALLOW_INTS;
- SCM_ASYNC_TICK;
- return coop_global_curr->retval;
+ int res = scm_c_thread_select (nfds, readfds, writefds, exceptfds, timeout);
#endif /* GUILE_ISELECT */
+ SCM_ASYNC_TICK;
+ return res;
}
/*
Index: libguile/iselect.h
===================================================================
RCS file: /cvs/guile/guile-core/libguile/iselect.h,v
retrieving revision 1.8
diff -u -r1.8 iselect.h
--- libguile/iselect.h 2000/03/19 19:01:12 1.8
+++ libguile/iselect.h 2001/04/07 04:40:38
@@ -90,15 +90,6 @@
SELECT_TYPE *efds,
struct timeval *timeout);
-#ifdef GUILE_ISELECT
-
-extern int scm_I_am_dead;
-
-extern void scm_error_revive_threads (void);
-extern void scm_init_iselect (void);
-
-#endif /* GUILE_ISELECT */
-
#endif
/*
Index: libguile/mallocs.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/mallocs.c,v
retrieving revision 1.22
diff -u -r1.22 mallocs.c
--- libguile/mallocs.c 2001/03/09 23:33:40 1.22
+++ libguile/mallocs.c 2001/04/07 04:40:38
@@ -64,10 +64,7 @@
{
scm_bits_t mem = n ? (scm_bits_t) malloc (n) : 0;
if (n && !mem)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
+ return SCM_BOOL_F;
SCM_RETURN_NEWSMOB (scm_tc16_malloc, mem);
}
Index: libguile/numbers.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/numbers.c,v
retrieving revision 1.123
diff -u -r1.123 numbers.c
--- libguile/numbers.c 2001/04/03 13:19:04 1.123
+++ libguile/numbers.c 2001/04/07 04:40:38
@@ -1392,10 +1392,10 @@
scm_memory_error (s_bignum);
SCM_NEWCELL (v);
- SCM_DEFER_INTS;
+ SCM_REDEFER_INTS;
SCM_SET_BIGNUM_BASE (v, scm_must_malloc (nlen * sizeof (SCM_BIGDIG),
s_bignum));
SCM_SETNUMDIGS (v, nlen, sign);
- SCM_ALLOW_INTS;
+ SCM_REALLOW_INTS;
return v;
}
Index: libguile/srcprop.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/srcprop.c,v
retrieving revision 1.45
diff -u -r1.45 srcprop.c
--- libguile/srcprop.c 2001/03/10 16:56:07 1.45
+++ libguile/srcprop.c 2001/04/07 04:40:38
@@ -148,6 +148,7 @@
ptr->fname = filename;
ptr->copy = copy;
ptr->plist = plist;
+ SCM_ALLOW_INTS;
SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr);
}
Index: libguile/threads.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/threads.c,v
retrieving revision 1.20
diff -u -r1.20 threads.c
--- libguile/threads.c 2001/03/09 23:33:41 1.20
+++ libguile/threads.c 2001/04/07 04:40:38
@@ -44,31 +44,27 @@
-/* This file does some pretty hairy #inclusion. It probably seemed
- like a good idea at the time, but it doesn't now. Here's the
- structure, edited for relevance (!), last I checked:
-
- threads.c:
- threads.h
- coop-defs.h
- iselect.h
- coop-threads.c
- coop-threads.h
- coop-defs.h*
- ../qt/qt.h
- coop.c
- <qt.h>
+#include <stdio.h>
- * second #inclusion
-*/
-
#include "libguile/_scm.h"
#include "libguile/dynwind.h"
+#include "libguile/root.h"
#include "libguile/smob.h"
+#include "libguile/dynl.h"
+#include "libguile/feature.h"
+#include "libguile/validate.h"
#include "libguile/threads.h"
+extern SCM scm_apply (SCM, SCM, SCM);
+extern void scm_threads_init (SCM_STACKITEM *);
+
+struct scm_threads scm_thread;
+/* A counter of the current number of threads */
+size_t scm_thread_count = 0;
+/* A count-down counter used to determine when to switch contexts */
+size_t scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
scm_bits_t scm_tc16_thread;
scm_bits_t scm_tc16_mutex;
@@ -77,77 +73,630 @@
/* Scheme-visible thread functions. */
-#ifdef USE_COOP_THREADS
-SCM_REGISTER_PROC(s_single_thread_p, "single-active-thread?", 0, 0, 0,
scm_single_thread_p);
-#endif
+/* NOTE: There are TWO mechanisms for starting a thread: The first one
+ is used when spawning a thread from Scheme, while the second one is
+ used from C.
+
+ It might be argued that the first should be implemented in terms of
+ the second. The reason it isn't is that that would require an
+ extra unnecessary malloc (the thread_args structure). By providing
+ one pair of extra functions (c_launch_thread, scm_spawn_thread) the
+ Scheme threads are started more efficiently. */
+
+/* This is the mechanism to spawn threads from C */
+
+typedef struct c_launch_data {
+ union {
+ SCM thread;
+ SCM rootcont;
+ } u;
+ SCM root_data;
+ scm_catch_body_t body;
+ void *body_data;
+ scm_catch_handler_t handler;
+ void *handler_data;
+} c_launch_data;
-/* GJB:FIXME:DOC: SCM_REGISTER_PROC needs to permit a docstring,
- or these need to move into the file where the proc is defined. */
+static SCM
+c_body_bootstrip (c_launch_data* data)
+{
+ /* First save the new root continuation */
+ data->u.rootcont = scm_root->rootcont;
+ return (data->body) (data->body_data);
+}
-SCM_REGISTER_PROC(s_yield, "yield", 0, 0, 0, scm_yield);
-/* If one or more threads are waiting to execute, calling yield forces an
-immediate context switch to one of them. Otherwise, yield has no effect.
-*/
+static SCM
+c_handler_bootstrip (c_launch_data* data, SCM tag, SCM throw_args)
+{
+ scm_root->rootcont = data->u.rootcont;
+ return (data->handler) (data->handler_data, tag, throw_args);
+}
-SCM_REGISTER_PROC(s_call_with_new_thread, "call-with-new-thread", 0, 0, 1,
scm_call_with_new_thread);
-/* Evaluate @var{(thunk)} in a new thread, and new dynamic context,
-returning a new thread object representing the thread.
+static void *
+c_launch_thread (void *p)
+{
+ register c_launch_data *data = (c_launch_data *) p;
+ /* The thread object will be GC protected by being on this stack */
+ /* Dirk:FIXME:: But, what is for the time between scm_spawn_thread and the
+ * invocation of c_launch_thread? During that time, the only reference to
+ * the thread and root objects is on the non-gc-controlled heap. */
+ SCM thread = data->u.thread;
+ SCM root = data->root_data;
+ (* scm_thread.set_thread_local_data) (SCM_ROOT_STATE (root));
+ /* We must use the address of `thread', otherwise the compiler will
+ optimize it away. This is OK since the longest SCM_STACKITEM
+ also is a long. */
+ scm_internal_cwdr ((scm_catch_body_t) c_body_bootstrip,
+ data,
+ (scm_catch_handler_t) c_handler_bootstrip,
+ data,
+ (SCM_STACKITEM *) &thread);
+ /* Dirk:FIXME:: In contrast to the scheme level launch function, the SCM
+ * thread object is not invalidated here. Thus, the thread data can still
+ * be accessed via the SCM thread object even after the thread has died. */
+ scm_thread_count--;
+ scm_must_free ((char *) data);
+ return NULL;
+}
-If an error occurs during evaluation, call error-thunk, passing it an
-error code describing the condition. [Error codes are currently
-meaningless integers. In the future, real values will be specified.]
-If this happens, the error-thunk is called outside the scope of the new
-root -- it is called in the same dynamic context in which
-with-new-thread was evaluated, but not in the callers thread.
+
+/* This is the mechanism to spawn threads from Scheme */
-All the evaluation rules for dynamic roots apply to threads.
-*/
+typedef struct scheme_launch_data {
+ SCM rootcont;
+ SCM body;
+ SCM handler;
+} scheme_launch_data;
-SCM_REGISTER_PROC(s_join_thread, "join-thread", 1, 0, 0, scm_join_thread);
-/* Suspend execution of the calling thread until the target @var{thread}
-terminates, unless the target @var{thread} has already terminated.
-*/
+static SCM
+scheme_body_bootstrip (scheme_launch_data* data)
+{
+ /* First save the new root continuation */
+ data->rootcont = scm_root->rootcont;
+ return scm_apply (data->body, SCM_EOL, SCM_EOL);
+}
-SCM_REGISTER_PROC(s_make_mutex, "make-mutex", 0, 0, 0, scm_make_mutex);
-/* Create a new mutex object. */
+static SCM
+scheme_handler_bootstrip (scheme_launch_data* data, SCM tag, SCM throw_args)
+{
+ scm_root->rootcont = data->rootcont;
+ return scm_apply (data->handler, scm_cons (tag, throw_args), SCM_EOL);
+}
-SCM_REGISTER_PROC(s_lock_mutex, "lock-mutex", 1, 0, 0, scm_lock_mutex);
-/* Lock @var{mutex}. If the mutex is already locked, the calling thread
-blocks until the mutex becomes available. The function returns when
-the calling thread owns the lock on @var{mutex}. */
+static void *
+scheme_launch_thread (void * p)
+{
+ /* The thread object will be GC protected by being a member of the
+ list given as argument to launch_thread. It will be marked
+ during the conservative sweep of the stack. */
+ register SCM argl = SCM_PACK (p);
+ SCM thread = SCM_CAR (argl);
+ SCM root = SCM_CADR (argl);
+ scheme_launch_data data;
+ (* scm_thread.set_thread_local_data) (SCM_ROOT_STATE (root));
+ data.rootcont = SCM_BOOL_F;
+ data.body = SCM_CADDR (argl);
+ data.handler = SCM_CADDDR (argl);
+ scm_internal_cwdr ((scm_catch_body_t) scheme_body_bootstrip,
+ &data,
+ (scm_catch_handler_t) scheme_handler_bootstrip,
+ &data,
+ (SCM_STACKITEM *) &thread);
+ /* Dirk:FIXME:: This code is probably necessary in order not to be able to
+ * access threads from scheme that have died. However, since 0 may be a
+ * valid value for some existing thread, this is insecure. Further, after
+ * this value has been set to 0, the function thread_free can not free the
+ * thread any more, since the thread id is not available.
+ * It would be better to have a status bit in the cell type that tells about
+ * whether the thread is still alive. The problem is, that the two accesses
+ * to the status bit and to the thread id could be interrupted. Thus, a
+ * mutex would be required to change and read the read status bit and thread
+ * data. However, since this is an essential mutex used by the threads
+ * implementation, it must be created at guile's startup. */
+ SCM_SET_THREAD_DATA (thread, 0);
+ scm_thread_count--;
+ SCM_DEFER_INTS;
+ return NULL;
+}
-SCM_REGISTER_PROC(s_unlock_mutex, "unlock-mutex", 1, 0, 0, scm_unlock_mutex);
-/* Unlocks @var{mutex} if the calling thread owns the lock on @var{mutex}.
-Calling unlock-mutex on a mutex not owned by the current thread results
-in undefined behaviour. Once a mutex has been unlocked, one thread
-blocked on @var{mutex} is awakened and grabs the mutex lock. */
+
-SCM_REGISTER_PROC(s_make_condition_variable, "make-condition-variable", 0, 0,
0, scm_make_condition_variable);
+SCM
+scm_spawn_thread (scm_catch_body_t body, void *body_data,
+ scm_catch_handler_t handler, void *handler_data)
+{
+ SCM old_winds;
+ SCM root;
+ SCM thread;
+ scm_thread_t thread_data;
+ c_launch_data *data = (c_launch_data *) scm_must_malloc (sizeof (*data),
"scm_spawn_thread");
+
+ /* Unwind wind chain. */
+ old_winds = scm_dynwinds;
+ scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
+
+ /* Allocate thread locals. */
+ root = scm_make_root (scm_root->handle);
+
+ /* Prepare parameters for c_launch_thread */
+ SCM_NEWCELL (thread);
+ SCM_DEFER_INTS;
+ SCM_SET_CELL_TYPE (thread, scm_tc16_thread);
+ data->u.thread = thread;
+ /* Dirk:Note:: We have to set the root data from within the new thread.
+ * This is different from the way it was done before.
+ */
+ data->root_data = root;
+ data->body = body;
+ data->body_data = body_data;
+ data->handler = handler;
+ data->handler_data = handler_data;
+ /* Dirk:FIXME:: What about the stack size settings? Note that if this is
+ * done, the data has to be passed also, since the setting has to be done
+ * from within the new thread.
+ */
+
+ /* Create thread */
+ thread_data = (* scm_thread.make_thread) (NULL, c_launch_thread, (void *)
data);
+ SCM_SET_THREAD_DATA (thread, thread_data);
+
+ scm_thread_count++;
+ /* Note that the following statement also could cause coop_yield.*/
+ SCM_ALLOW_INTS;
+
+ /* We're now ready for the thread to begin. */
+ (*scm_thread.thread_yield) ();
+
+ /* Return to old dynamic context. */
+ scm_dowinds (old_winds, - scm_ilength (old_winds));
+
+ return thread;
+}
+
+
+SCM_DEFINE(scm_call_with_new_thread, "call-with-new-thread", 2, 0, 0,
+ (SCM thunk, SCM error_thunk),
+ "Evaluate @var{(thunk)} in a new thread, and new dynamic\n"
+ "context, returning a new thread object representing the thread.\n"
+ "If an error occurs during evaluation, call error-thunk, passing\n"
+ "it an error code describing the condition. [Error codes are\n"
+ "currently meaningless integers. In the future, real values\n"
+ "will be specified.] If this happens, the error-thunk is called\n"
+ "outside the scope of the new root -- it is called in the same\n"
+ "dynamic context in which call-with-new-thread was evaluated, but\n"
+ "not in the callers thread. All the evaluation rules for dynamic\n"
+ "roots apply to threads.")
+#define FUNC_NAME s_scm_call_with_new_thread
+{
+ SCM old_winds;
+ SCM root;
+ SCM thread;
+ scm_thread_t thread_data;
+ SCM args;
+
+ SCM_VALIDATE_THUNK (1, thunk);
+ SCM_VALIDATE_THUNK (2, error_thunk);
+
+ /* Unwind wind chain. */
+ old_winds = scm_dynwinds;
+ scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
+
+ /* Allocate thread locals. */
+ root = scm_make_root (scm_root->handle);
+
+ /* Prepare parameters for scheme_launch_thread */
+ SCM_NEWCELL (thread);
+ SCM_DEFER_INTS;
+ SCM_SET_CELL_TYPE (thread, scm_tc16_thread);
+ args = scm_cons (error_thunk, SCM_EOL);
+ args = scm_cons (thunk, args);
+ /* Dirk:Note:: We have to set the root data from within the new thread.
+ * This is different from the way it was done before.
+ */
+ args = scm_cons (root, args);
+ args = scm_cons (thread, args);
+ /* Dirk:FIXME:: What about the stack size settings? Note that if this is
+ * done, the data has to be passed also, since the setting has to be done
+ * from within the new thread.
+ */
+
+ /* Create thread */
+ thread_data = (* scm_thread.make_thread) (NULL, scheme_launch_thread, (void
*) SCM_UNPACK (args));
+ SCM_SET_THREAD_DATA (thread, thread_data);
+
+ scm_thread_count++;
+ /* Note that the following statement also could cause coop_yield.*/
+ SCM_ALLOW_INTS;
+
+ /* We're now ready for the thread to begin. */
+ (*scm_thread.thread_yield) ();
+
+ /* Return to old dynamic context. */
+ scm_dowinds (old_winds, - scm_ilength (old_winds));
+
+ return thread;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE(scm_thread_p, "thread?", 1, 0, 0,
+ (SCM obj),
+ "Return #t iff OBJ is a thread object.")
+#define FUNC_NAME s_scm_thread_p
+{
+ return SCM_BOOL (SCM_THREADP (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE(scm_thread_exit, "thread-exit", 1, 0, 0,
+ (SCM result),
+ "Finish the currently running thread and return RESULT.")
+#define FUNC_NAME s_scm_thread_exit
+{
+ /* Dirk:FIXME:: Guile hangs when doing thread-exit in the repl. */
+ /* Dirk:FIXME:: Guile hangs when doing thread-exit without params. */
+
+ (* scm_thread.thread_exit) ((void *) SCM_UNPACK (result));
+ return SCM_BOOL_T; /* not reached */
+}
+#undef FUNC_NAME
-SCM_REGISTER_PROC(s_wait_condition_variable, "wait-condition-variable", 2, 0,
0, scm_wait_condition_variable);
-SCM_REGISTER_PROC(s_signal_condition_variable, "signal-condition-variable", 1,
0, 0, scm_signal_condition_variable);
+SCM_DEFINE(scm_thread_cancel, "thread-cancel", 1, 0, 0,
+ (SCM thread),
+ "Abort the execution of THREAD.")
+#define FUNC_NAME s_scm_thread_cancel
+{
+ scm_thread_t thread_data;
+ SCM_VALIDATE_THREAD (1, thread);
+ thread_data = SCM_THREAD_DATA (thread);
+ if (thread_data)
+ /* The thread is still alive */
+ (* scm_thread.thread_cancel) (thread_data);
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+static scm_sizet
+thread_free (SCM thread)
+{
+ scm_thread_t thread_data = SCM_THREAD_DATA (thread);
+ if (thread_data)
+ /* The thread is still alive */
+ return (* scm_thread.thread_free) (thread_data);
+ else
+ /* Dirk:FIXME:: If the thread has exited, then the thread data is 0.
+ * This has to be solved in a better way. */
+ return 0;
+}
+
+
+#if (SCM_DEBUG_DEPRECATED == 0)
+
+SCM_REGISTER_PROC(s_join_thread, "join-thread", 1, 0, 0, scm_thread_join);
+
+#endif /* SCM_DEBUG_DEPRECATED == 0 */
+
+SCM_DEFINE(scm_thread_join, "thread-join", 1, 0, 0,
+ (SCM thread),
+ "Suspend execution of the calling thread until the target\n"
+ "@var{thread} terminates, unless the target @var{thread} has\n"
+ "already terminated.")
+#define FUNC_NAME s_scm_thread_join
+{
+ SCM_VALIDATE_THREAD (1, thread);
+ (* scm_thread.thread_join) (thread, NULL);
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
-#ifdef USE_COOP_THREADS
-#include "libguile/coop-threads.c"
-#endif
+#if (SCM_DEBUG_DEPRECATED == 0)
+
+SCM_REGISTER_PROC(s_scm_yield, "yield", 0, 0, 0, scm_thread_yield);
+
+#endif /* SCM_DEBUG_DEPRECATED == 0 */
+SCM_DEFINE(scm_thread_yield, "thread-yield", 0, 0, 0,
+ (),
+ "If one or more threads are waiting to execute, calling\n"
+ "thread-yield forces an immediate context switch to one of them.\n"
+ "Otherwise, thread-yield has no effect.")
+#define FUNC_NAME s_scm_thread_yield
+{
+ scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
+ (* scm_thread.thread_yield) ();
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE(scm_make_mutex, "make-mutex", 0, 0, 0,
+ (),
+ "Create a new mutex object.")
+#define FUNC_NAME s_scm_make_mutex
+{
+ SCM mutex;
+ scm_mutex_t * mutex_data = (* scm_thread.make_mutex) (NULL);
+ SCM_NEWSMOB (mutex, scm_tc16_mutex, mutex_data);
+ return mutex;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE(scm_mutex_p, "mutex?", 1, 0, 0,
+ (SCM obj),
+ "Return #t iff OBJ is a mutex object.")
+#define FUNC_NAME s_scm_mutex_p
+{
+ return SCM_BOOL (SCM_MUTEXP (obj));
+}
+#undef FUNC_NAME
+
+
+#if (SCM_DEBUG_DEPRECATED == 0)
+
+SCM_REGISTER_PROC(s_lock_mutex, "lock-mutex", 1, 0, 0, scm_mutex_lock);
+
+#endif /* SCM_DEBUG_DEPRECATED == 0 */
+
+SCM_DEFINE(scm_mutex_lock, "mutex-lock", 1, 0, 0,
+ (SCM mutex),
+ "Lock @var{mutex}. If the mutex is already locked, the calling\n"
+ "thread blocks until the mutex becomes available. The function\n"
+ "returns when the calling thread owns the lock on @var{mutex}.")
+#define FUNC_NAME s_scm_mutex_lock
+{
+ SCM_ASSERT (SCM_MUTEXP (mutex), mutex, SCM_ARG1, s_scm_mutex_lock);
+ (* scm_thread.mutex_lock) (SCM_MUTEX_DATA (mutex));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE(scm_mutex_trylock, "mutex-trylock", 1, 0, 0,
+ (SCM mutex),
+ "If the @var{mutex} is not locked yet, lock it and return #t.\n"
+ "Otherwise, if the mutex is already locked, return #f. The\n"
+ "calling thread is never blocked.")
+#define FUNC_NAME s_scm_mutex_trylock
+{
+ SCM_ASSERT (SCM_MUTEXP (mutex), mutex, SCM_ARG1, s_scm_mutex_lock);
+ return SCM_BOOL ((* scm_thread.mutex_trylock) (SCM_MUTEX_DATA (mutex)) == 0);
+}
+#undef FUNC_NAME
+
+
+#if (SCM_DEBUG_DEPRECATED == 0)
+
+SCM_REGISTER_PROC(s_unlock_mutex, "unlock-mutex", 1, 0, 0, scm_mutex_unlock);
+
+#endif /* SCM_DEBUG_DEPRECATED == 0 */
+
+SCM_DEFINE(scm_mutex_unlock, "mutex-unlock", 1, 0, 0,
+ (SCM mutex),
+ "Unlocks @var{mutex} if the calling thread owns the lock on\n"
+ "@var{mutex}. Calling unlock-mutex on a mutex not owned by the\n"
+ "current thread results in undefined behaviour. Once a mutex\n"
+ "has been unlocked, one thread blocked on @var{mutex} is\n"
+ "awakened and grabs the mutex lock.")
+#define FUNC_NAME s_scm_mutex_unlock
+{
+ /* Dirk:FIXME:: What if the mutex was not locked before? */
+
+ SCM_ASSERT (SCM_MUTEXP (mutex), mutex, SCM_ARG1, s_scm_mutex_unlock);
+ (* scm_thread.mutex_unlock) (SCM_MUTEX_DATA (mutex));
+
+ /* Yield early */
+ scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
+ (* scm_thread.thread_yield) ();
+
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+static scm_sizet
+mutex_free (SCM mutex)
+{
+ /* Dirk:FIXME:: What happens to the threads that are blocked because of this
+ * mutex? They will never wake up again. */
+
+ return (* scm_thread.mutex_free) (SCM_MUTEX_DATA (mutex));
+}
+
+
+
+SCM_DEFINE(scm_make_cond, "make-cond", 0, 0, 0,
+ (),
+ "")
+#define FUNC_NAME s_scm_make_cond
+{
+ SCM cond;
+ scm_cond_t * cond_data = (* scm_thread.make_cond) (NULL);
+ SCM_NEWSMOB (cond, scm_tc16_condvar, cond_data);
+ return cond;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE(scm_cond_p, "cond?", 1, 0, 0,
+ (SCM obj),
+ "Return #t iff OBJ is a condition variable object.")
+#define FUNC_NAME s_scm_cond_p
+{
+ return SCM_BOOL (SCM_CONDVARP (obj));
+}
+#undef FUNC_NAME
+
+
+#if (SCM_DEBUG_DEPRECATED == 0)
+
+SCM_REGISTER_PROC(s_signal_condition_variable, "signal-condition-variable", 1,
0, 0, scm_cond_signal);
+
+#endif /* SCM_DEBUG_DEPRECATED == 0 */
+
+SCM_DEFINE(scm_cond_signal, "cond-signal", 1, 0, 0,
+ (SCM cond),
+ "")
+#define FUNC_NAME s_scm_cond_signal
+{
+ SCM_ASSERT (SCM_CONDVARP (cond), cond, SCM_ARG1, FUNC_NAME);
+ (* scm_thread.cond_signal) (SCM_CONDVAR_DATA (cond));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE(scm_cond_broadcast, "cond-broadcast", 1, 0, 0,
+ (SCM cond),
+ "")
+#define FUNC_NAME s_scm_cond_broadcast
+{
+ SCM_ASSERT (SCM_CONDVARP (cond), cond, SCM_ARG1, FUNC_NAME);
+ (* scm_thread.cond_broadcast) (SCM_CONDVAR_DATA (cond));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+#if (SCM_DEBUG_DEPRECATED == 0)
+
+SCM_REGISTER_PROC(s_wait_condition_variable, "wait-condition-variable", 2, 0,
0, scm_cond_wait);
+
+#endif /* SCM_DEBUG_DEPRECATED == 0 */
+
+SCM_DEFINE(scm_cond_wait, "cond-wait", 2, 0, 0,
+ (SCM cond, SCM mutex),
+ "")
+#define FUNC_NAME s_scm_cond_wait
+{
+ SCM_ASSERT (SCM_CONDVARP (cond), cond, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_MUTEXP (mutex), mutex, SCM_ARG1, FUNC_NAME);
+ (* scm_thread.cond_wait) (SCM_CONDVAR_DATA (cond), SCM_MUTEX_DATA (mutex));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE(scm_cond_timedwait, "cond-timedwait", 4, 0, 0,
+ (SCM cond, SCM mutex, SCM seconds, SCM nanoseconds),
+ "")
+#define FUNC_NAME s_scm_cond_timedwait
+{
+ struct timespec t;
+ SCM_ASSERT (SCM_CONDVARP (cond), cond, 1, FUNC_NAME);
+ SCM_ASSERT (SCM_MUTEXP (mutex), mutex, 2, FUNC_NAME);
+ SCM_VALIDATE_INUM (3, seconds);
+ SCM_VALIDATE_INUM (4, nanoseconds);
+ t.tv_sec = SCM_INUM (seconds);
+ t.tv_nsec = SCM_INUM (nanoseconds);
+ (* scm_thread.cond_timedwait) (SCM_CONDVAR_DATA (cond), SCM_MUTEX_DATA
(mutex), &t);
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+static scm_sizet
+cond_free (SCM cond)
+{
+ return (* scm_thread.cond_free) (SCM_CONDVAR_DATA (cond));
+}
+
+
+
+unsigned long
+scm_thread_usleep (unsigned long usec)
+{
+ struct timeval timeout;
+ timeout.tv_sec = 0;
+ timeout.tv_usec = usec;
+ (* scm_thread.thread_select) (0, NULL, NULL, NULL, &timeout);
+ return 0; /* Maybe we should calculate actual time slept,
+ but this is faster... :) */
+}
+
+unsigned long
+scm_thread_sleep (unsigned long sec)
+{
+ time_t now = time (NULL);
+ struct timeval timeout;
+ unsigned long slept;
+ timeout.tv_sec = sec;
+ timeout.tv_usec = 0;
+ (* scm_thread.thread_select) (0, NULL, NULL, NULL, &timeout);
+ slept = time (NULL) - now;
+ return slept > sec ? 0 : sec - slept;
+}
+
void
-scm_init_threads (SCM_STACKITEM *i)
+scm_init_threads (void)
{
+ SCM dl_handle, dl_func;
+
scm_tc16_thread = scm_make_smob_type ("thread", 0);
- scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (coop_m));
- scm_tc16_condvar = scm_make_smob_type ("condition-variable", sizeof
(coop_c));
-
+ scm_set_smob_free (scm_tc16_thread, thread_free);
+ scm_tc16_mutex = scm_make_smob_type ("mutex", 0);
+ scm_set_smob_free (scm_tc16_mutex, mutex_free);
+ scm_tc16_condvar = scm_make_smob_type ("condition-variable", 0);
+ scm_set_smob_free (scm_tc16_condvar, cond_free);
#ifndef SCM_MAGIC_SNARFER
#include "libguile/threads.x"
#endif
/* Initialize implementation specific details of the threads support */
- scm_threads_init (i);
+ /* Dirk:FIXME:: We should initialize the functions with some default, and
+ * have the thread library dynamically loaded later. However, what if some
+ * features are needed from the start, like a mutex that is needed by the
+ * wrapper functions in this file? Further, how to deal with thread, mutex
+ * etc. objects that were created by threading system a) when system b) is
+ * dynamically loaded? */
+#if 1
+ /* XXX: Should check errors */
+
+ dl_handle = scm_dynamic_link (scm_makfrom0str ("libguileqthreads"));
+ dl_func = scm_dynamic_func (scm_makfrom0str ("scm_threads_init"), dl_handle);
+ scm_dynamic_call (dl_func, dl_handle);
+ scm_add_feature ("threads");
+#else
+ scm_thread.make_thread = null_error;
+ scm_thread.thread_exit = null_error;
+ scm_thread.thread_cancel = null_error;
+ scm_thread.thread_join = null_error;
+ scm_thread.thread_free = null_error;
+ scm_thread.thread_yield = null_do_nothing;
+ scm_thread.thread_select = null_select;
+
+ scm_thread.make_mutex = null_error;
+ scm_thread.mutex_free = null_error;
+
+ scm_thread.mutex_lock = null_mutex_lock;
+ scm_thread.mutex_trylock = null_mutex_trylock;
+ scm_thread.mutex_unlock = null_mutex_unlock;
+
+ scm_thread.make_cond = null_error;
+ scm_thread.cond_free = null_error;
+
+ scm_thread.cond_signal = null_do_nothing;
+ scm_thread.cond_broadcast = null_do_nothing;
+ scm_thread.cond_wait = null_error;
+ scm_thread.cond_timedwait = null_error;
+
+ scm_thread.key_create = null_key_create;
+ scm_thread.key_delete = null_key_delete;
+
+ scm_thread.set_thread_specific_data = null_set_thread_specific_data;
+ scm_thread.thread_specific_data = null_thread_specific_data;
+
+ scm_thread.set_thread_local_data = null_set_thread_local_data;
+ scm_thread.thread_local_data = null_thread_local_data;
+
+ scm_thread.threads_mark_stacks = null_threads_mark_stacks;
+ scm_thread.set_threads_stack_size = null_set_threads_stack_size;
+#endif
}
/*
Index: libguile/threads.h
===================================================================
RCS file: /cvs/guile/guile-core/libguile/threads.h,v
retrieving revision 1.15
diff -u -r1.15 threads.h
--- libguile/threads.h 2000/12/10 20:34:01 1.15
+++ libguile/threads.h 2001/04/07 04:40:38
@@ -52,15 +52,172 @@
#include "libguile/procs.h"
#include "libguile/throw.h"
+/* Dirk:FIXME:: Where should this go? All the definitions below (up to
+ * FD_ZERO are needed only for scm_thread.thread_select. They are repeated
+ * for all headers that provide select-functionality. */
+
+/* Needed for FD_SET on some systems. */
+#include <sys/types.h>
+
+#ifdef TIME_WITH_SYS_TIME
+# include <sys/time.h>
+# include <time.h>
+#else
+# ifdef HAVE_SYS_TIME_H
+# include <sys/time.h>
+# else
+# ifdef HAVE_TIME_H
+# include <time.h>
+# endif
+# endif
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_SYS_SELECT_H
+#include <sys/select.h>
+#endif
+
+#ifdef FD_SET
+
+#define SELECT_TYPE fd_set
+#define SELECT_SET_SIZE FD_SETSIZE
+
+#else /* no FD_SET */
+
+/* Define the macros to access a single-int bitmap of descriptors. */
+#define SELECT_SET_SIZE 32
+#define SELECT_TYPE int
+#define FD_SET(n, p) (*(p) |= (1 << (n)))
+#define FD_CLR(n, p) (*(p) &= ~(1 << (n)))
+#define FD_ISSET(n, p) (*(p) & (1 << (n)))
+#define FD_ZERO(p) (*(p) = 0)
+
+#endif /* no FD_SET */
+
+/* The definition of the thread related data types is targeted towards
+ * compatibility with pthreads. This will allow to plug in most of the
+ * pthreads functions without need for extra intermediate glue code. For
+ * other thread implementations this may require additional effort in the glue
+ * code, though.
+ */
+typedef unsigned long int scm_thread_t;
+typedef struct scm_threadattr scm_threadattr_t;
+typedef struct scm_mutex scm_mutex_t;
+typedef struct scm_mutexattr scm_mutexattr_t;
+typedef struct scm_cond scm_cond_t;
+typedef struct scm_condattr scm_condattr_t;
+typedef unsigned int scm_key_t;
+
+/* Dirk:FIXME:: Where should this go? It doesn't seem good to have it here. */
+#ifndef HAVE_STRUCT_TIMESPEC
+/* POSIX.4 structure for a time value. This is like a `struct timeval' but
+ has nanoseconds instead of microseconds. */
+struct timespec
+{
+ long int tv_sec; /* Seconds. */
+ long int tv_nsec; /* Nanoseconds. */
+};
+#endif
+
+
+/* Dirk:FIXME:: As we are calling glue code anyway, wouldn't it make sense to
+ * use guile specific data types, like an alist with (symbol . value) pairs
+ * for attributes? Or, scm_bits_t instead of void* data? Or SCM values for
+ * return data? The glue code can perform the transformation. Especially for
+ * creation and destruction of threads, mutexes etc. this would be feasible,
+ * since these functions are probably not too time critical.
+ *
+ * Also, instead of a dedicated function to set the stack size, there should
+ * be two functions:
+ * 1) set_default_thread_parameters and
+ * 2) set_thread_parameters, which both should be alists IMO.
+ *
+ * Further, threads_mark_stacks should IMO be renamed to something more
+ * general, since it is not just stacks that are to be marked.
+ */
+struct scm_threads {
+ /* Threads */
+ /* Dirk:FIXME:: What is the start_routine expected to return? */
+ scm_thread_t (*make_thread) (scm_threadattr_t * attr, void *
(*start_routine) (void *), void * arg);
+ void (*thread_exit) (void * retval);
+ int (*thread_cancel) (scm_thread_t thread);
+ /* Dirk:FIXME:: What is the retval supposed to be? */
+ int (*thread_join) (scm_thread_t thread, void ** retval);
+ size_t (*thread_free) (scm_thread_t thread); /* returns freed amount of
memory */
+
+ /* Cooperative threads (optional) */
+ void (*thread_yield) (void);
+ /* Dirk:FIXME:: Should the name be changed to select? */
+ /* Dirk:FIXME:: Is this interface OK? */
+ int (*thread_select)
+ (int fds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds, struct
timeval *timeout);
+
+ /* Mutecis */
+ scm_mutex_t * (*make_mutex) (const scm_mutexattr_t * mutexattr);
+ /* Dirk:FIXME:: What is the return value needed for? */
+ int (*mutex_lock) (scm_mutex_t * mutex);
+ int (*mutex_trylock) (scm_mutex_t * mutex);
+ /* Dirk:FIXME:: What is the return value needed for? */
+ int (*mutex_unlock) (scm_mutex_t * mutex);
+ size_t (*mutex_free) (scm_mutex_t * mutex); /* returns freed amount of
memory */
+
+ /* Condition variables */
+ scm_cond_t * (*make_cond) (const scm_condattr_t * cond_attr);
+ /* Dirk:FIXME:: What is the return value needed for? */
+ int (*cond_signal) (scm_cond_t * cond);
+ /* Dirk:FIXME:: What is the return value needed for? */
+ int (*cond_broadcast) (scm_cond_t * cond);
+ /* Dirk:FIXME:: What is the return value needed for? */
+ int (*cond_wait) (scm_cond_t * cond, scm_mutex_t * mutex);
+ /* Dirk:FIXME:: What is the return value needed for? */
+ int (*cond_timedwait) (scm_cond_t * cond, scm_mutex_t * mutex, const struct
timespec * abstime);
+ size_t (*cond_free) (scm_cond_t * cond); /* returns freed amount of memory */
+
+ /* Keys */
+ /* Dirk:FIXME:: What is the return value needed for? */
+ /* Dirk:FIXME:: What does the parameter destr_function do? */
+ /* Dirk:FIXME:: Shouldn't there rather be functions make-key, key_delete,
key_free? */
+ int (*key_create) (scm_key_t * key, void (*destr_function) (void *));
+ /* Dirk:FIXME:: What is the return value needed for? */
+ int (*key_delete) (scm_key_t key);
+
+ /* Thread specific data */
+ /* Dirk:FIXME:: Neither implemented nor used yet: */
+ /* Dirk:FIXME:: What is the return value needed for? */
+ int (*set_thread_specific_data) (scm_key_t key, const void *);
+ /* Dirk:FIXME:: Neither implemented nor used yet: */
+ void * (*thread_specific_data) (scm_key_t key);
+ /* Dirk:FIXME:: shouldn't the parameter be a scm_root_state* ? */
+ void (*set_thread_local_data) (void * data);
+ void * (*thread_local_data) (void);
+
+ /* Garbage collection */
+ void (*threads_mark_stacks) (void);
+
+ /* Parameters */
+ void (*set_threads_stack_size) (size_t size);
+};
+
+extern struct scm_threads scm_thread;
+
+extern size_t scm_thread_count; /* counts between context switches */
+extern size_t scm_switch_counter; /* count-down until next switch. 0 = no
switching */
+
+
+/* */
/* smob tags for the thread datatypes */
extern scm_bits_t scm_tc16_thread;
extern scm_bits_t scm_tc16_mutex;
extern scm_bits_t scm_tc16_condvar;
#define SCM_THREADP(x) SCM_TYP16_PREDICATE (scm_tc16_thread, x)
-#define SCM_THREAD_DATA(x) ((void *) SCM_CELL_WORD_1 (x))
+#define SCM_THREAD_DATA(x) SCM_CELL_WORD_1 (x)
+#define SCM_SET_THREAD_DATA(x, v) (SCM_SET_CELL_WORD_1 ((x), (v)))
#define SCM_MUTEXP(x) SCM_TYP16_PREDICATE (scm_tc16_mutex, x)
#define SCM_MUTEX_DATA(x) ((void *) SCM_CELL_WORD_1 (x))
@@ -68,43 +225,97 @@
#define SCM_CONDVARP(x) SCM_TYP16_PREDICATE (scm_tc16_condvar, x)
#define SCM_CONDVAR_DATA(x) ((void *) SCM_CELL_WORD_1 (x))
-/* Initialize implementation specific details of the threads support */
-void scm_threads_init (SCM_STACKITEM *);
-void scm_threads_mark_stacks (void);
-void scm_init_threads (SCM_STACKITEM *);
+/*
+ * C interface
+ */
+
+/* Dirk:Fixme:: Should these macros be eliminated? */
+#define SCM_THREAD_LOCAL_DATA ((* scm_thread.thread_local_data) ())
+#define SCM_SET_THREAD_LOCAL_DATA(v) ((* scm_thread.set_thread_local_data) (v))
+/* Dirk:FIXME:: This has to be fixed. For cooperative threads it's OK though.
*/
+#define SCM_THREAD_CRITICAL_SECTION_START
+#define SCM_THREAD_CRITICAL_SECTION_END
+
+SCM scm_spawn_thread (scm_catch_body_t, void *, scm_catch_handler_t, void *);
+
+#define scm_c_thread_yield() ((* scm_thread.thread_yield) ())
+#define scm_c_thread_select(f,r,w,e,t) ((* scm_thread.thread_select) (f, r, w,
e, t))
+
+#define scm_c_make_mutex(a) ((* scm_thread.make_mutex) (a))
+#define scm_c_mutex_lock(m) ((* scm_thread.mutex_lock) (m))
+#define scm_c_mutex_trylock(m) ((* scm_thread.mutex_trylock) (m))
+#define scm_c_mutex_unlock(m) ((* scm_thread.mutex_unlock) (m))
+
+#define scm_c_make_cond(a) ((* scm_thread.make_cond) (a))
+#define scm_c_cond_signal(c) ((* scm_thread.cond_signal) (c))
+#define scm_c_cond_broadcast(c) ((* scm_thread.cond_broadcast) (c))
+#define scm_c_cond_wait(c, m) ((* scm_thread.cond_wait) (c, m))
+#define scm_c_cond_timedwait(c, m, t) ((* scm_thread.cond_timedwait) (c, m, t))
+
+#define scm_c_key_create(k, f) ((* scm_thread.key_create) (k, f))
+#define scm_c_key_delete(k) ((* scm_thread.key_delete) (k))
+
+/* Dirk:FIXME:: How to name these?
+#define scm_c_setspecific scm_thread.setspecific
+#define scm_c_getspecific scm_thread.getspecific
+*/
-/* */
-SCM scm_threads_make_mutex (void);
-SCM scm_threads_lock_mutex (SCM);
-SCM scm_threads_unlock_mutex (SCM);
-SCM scm_threads_monitor (void);
-
-SCM scm_spawn_thread (scm_catch_body_t body, void *body_data,
- scm_catch_handler_t handler, void *handler_data);
+#define scm_threads_mark_stacks() ((* scm_thread.threads_mark_stacks) ())
/* These are versions of the ordinary sleep and usleep functions,
that play nicely with the thread system. */
unsigned long scm_thread_sleep (unsigned long);
unsigned long scm_thread_usleep (unsigned long);
+/* Initialization. */
+void scm_init_threads (void);
-/* The C versions of the Scheme-visible thread functions. */
-#ifdef USE_COOP_THREADS
-extern SCM scm_single_thread_p (void);
-#endif
-extern SCM scm_yield (void);
-extern SCM scm_call_with_new_thread (SCM argl);
-extern SCM scm_join_thread (SCM t);
+
+/*
+ * Scheme interface.
+ */
+
+/* Dirk:FIXME:: The name call_with_new_thread does not fit very nicely with
+ * with rest of the functions. I'd rather use make_thread or spawn_thread,
+ * but both in sync with the C level function names. make_thread, however, is
+ * defined as a macro in ice-9/threads.scm. */
+extern SCM scm_call_with_new_thread (SCM thunk, SCM error_thunk);
+/* Dirk:FIXME:: Neither implemented nor used yet. What shall it do? */
+extern SCM scm_m_begin_thread (SCM exp, SCM env);
+extern SCM scm_thread_p (SCM obj);
+extern SCM scm_thread_exit (SCM retval);
+extern SCM scm_thread_cancel (SCM thread);
+extern SCM scm_thread_join (SCM t);
+
+extern SCM scm_thread_yield (void);
+/* Dirk:FIXME:: Should the common select and the thread based select function
+ * be merged? The following definition is from filesys.h */
+/* extern SCM scm_select (SCM reads, SCM writes, SCM excepts, SCM secs, SCM
msecs); */
+
extern SCM scm_make_mutex (void);
-extern SCM scm_lock_mutex (SCM m);
-extern SCM scm_unlock_mutex (SCM m);
-extern SCM scm_make_condition_variable (void);
-extern SCM scm_wait_condition_variable (SCM cond, SCM mutex);
-extern SCM scm_signal_condition_variable (SCM cond);
+extern SCM scm_mutex_p (SCM obj);
+extern SCM scm_mutex_lock (SCM m);
+extern SCM scm_mutex_trylock (SCM m);
+extern SCM scm_mutex_unlock (SCM m);
+
+extern SCM scm_make_cond (void);
+extern SCM scm_cond_p (SCM obj);
+extern SCM scm_cond_signal (SCM cond);
+extern SCM scm_cond_broadcast (SCM cond);
+extern SCM scm_cond_wait (SCM cond, SCM mutex);
+extern SCM scm_cond_timedwait (SCM cond, SCM mutex, SCM seconds, SCM
nanoseconds);
-#ifdef USE_COOP_THREADS
-#include "libguile/coop-defs.h"
-#endif
+
+
+#if (SCM_DEBUG_DEPRECATED == 0)
+
+#define scm_join_thread scm_thread_join
+#define scm_lock_mutex scm_mutex_lock
+#define scm_unlock_mutex scm_mutex_unlock
+#define scm_wait_condition_variable scm_cond_wait
+#define scm_signal_condition_variable scm_cond_signal
+
+#endif /* SCM_DEBUG_DEPRECATED == 0 */
#endif /* THREADSH */
Index: test-suite/lib.scm
===================================================================
RCS file: /cvs/guile/guile-core/test-suite/lib.scm,v
retrieving revision 1.17
diff -u -r1.17 lib.scm
--- test-suite/lib.scm 2001/03/05 11:05:02 1.17
+++ test-suite/lib.scm 2001/04/07 04:40:38
@@ -275,7 +275,7 @@
;;; A short form for tests that are expected to pass, taken from Greg.
(defmacro pass-if (name body . rest)
- `(run-test ,name #t (lambda () ,body ,@rest)))
+ `(run-test ,name #t (lambda () (not (not (begin ,body ,@rest))))))
;;; A short form for tests that are expected to fail, taken from Greg.
(defmacro expect-fail (name body . rest)
Index: test-suite/tests/threads.test
===================================================================
RCS file: threads.test
diff -N threads.test
--- /dev/null Tue Feb 13 06:06:23 2001
+++ threads.test Fri Apr 6 21:40:39 2001
@@ -0,0 +1,286 @@
+;;;; threads.test --- tests guile's threads -*- scheme -*-
+;;;; Copyright (C) 2000 Free Software Foundation, Inc.
+;;;;
+;;;; This program 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 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+;;;; As a special exception, the Free Software Foundation gives permission
+;;;; for additional uses of the text contained in its release of GUILE.
+;;;;
+;;;; The exception is that, if you link the GUILE library with other files
+;;;; to produce an executable, this does not by itself cause the
+;;;; resulting executable to be covered by the GNU General Public License.
+;;;; Your use of that executable is in no way restricted on account of
+;;;; linking the GUILE library code into it.
+;;;;
+;;;; This exception does not however invalidate any other reasons why
+;;;; the executable file might be covered by the GNU General Public License.
+;;;;
+;;;; This exception applies only to the code released by the
+;;;; Free Software Foundation under the name GUILE. If you copy
+;;;; code from other Free Software Foundation releases into a copy of
+;;;; GUILE, as the General Public License permits, the exception does
+;;;; not apply to the code that you add in this way. To avoid misleading
+;;;; anyone as to the status of such modified files, you must delete
+;;;; this exception notice from them.
+;;;;
+;;;; If you write modifications of your own for GUILE, it is your choice
+;;;; whether to permit this exception to apply to your modifications.
+;;;; If you do not wish that, delete this exception notice.
+
+(use-modules (ice-9 documentation))
+
+;;;
+;;; miscellaneous
+;;;
+
+(define (documented? object)
+ (not (not (object-documentation object))))
+
+(define (check-feature feature)
+ (if (not (provided? feature))
+ (throw 'unsupported)))
+
+(define (default-error-handler)
+ #t)
+
+
+(defmacro repeat (count body . rest)
+ `(let ((c ,count))
+ (do ((i 0 (+ i 1)))
+ ((= i ,count))
+ ,body
+ ,@rest)))
+
+
+;;;
+;;; threads
+;;;
+
+(with-test-prefix "threads"
+
+ (with-test-prefix "call-with-new-thread"
+
+ (expect-fail "documented?"
+ (check-feature 'threads)
+ (documented? "call-with-new-thread"))
+
+ (pass-if "thread runs and exits"
+ (check-feature 'threads)
+ (let* ((flag #f)
+ (function (lambda () (set! flag #t)))
+ (thread (call-with-new-thread function default-error-handler)))
+ (thread-join thread)
+ flag))
+
+ ;; Check for threads spawning other threads
+
+ ;; Check for correct application of the error handler
+
+ ;; Check for correct handling of parameter errors
+ ;; 1) wrong type instead of thread function
+ ;; 2) wrong thread function arity
+ ;; 3) wrong type instead of handler function
+ ;; 4) wrong handler function arity
+
+ )
+
+ (with-test-prefix "thread?"
+
+ (expect-fail "documented?"
+ (check-feature 'threads)
+ (documented? "thread?"))
+
+ (pass-if "new thread"
+ (check-feature 'threads)
+ (let* ((function (lambda () #t))
+ (t (call-with-new-thread function default-error-handler)))
+ (thread? t)))
+
+ (pass-if "non-thread"
+ (check-feature 'threads)
+ (not (thread? 0))))
+
+ (with-test-prefix "thread-exit"
+
+ (expect-fail "documented?"
+ (check-feature 'threads)
+ (documented? "thread-exit"))
+
+ (pass-if "thread exits appropriately"
+ (check-feature 'threads)
+ (let* ((flag #f)
+ (function (lambda () (thread-exit 0) (set! flag #t)))
+ (thread (call-with-new-thread function default-error-handler)))
+ (thread-join thread)
+ (not flag)))
+
+ ;; Check for parameter errors
+
+ )
+
+ (with-test-prefix "thread-cancel"
+
+ (expect-fail "documented?"
+ (check-feature 'threads)
+ (documented? "thread-cancel"))
+
+ (pass-if "thread exits appropriately"
+ (check-feature 'threads)
+ (throw 'untested)))
+
+ (with-test-prefix "thread-join"
+
+ (expect-fail "documented?"
+ (check-feature 'threads)
+ (documented? "thread-join")))
+
+ (with-test-prefix "thread-yield"
+
+ (expect-fail "documented?"
+ (check-feature 'coop-threads)
+ (documented? "thread-yield"))
+
+ (pass-if "assignment after yield"
+ (check-feature 'coop-threads)
+ (let* ((flag #f)
+ (function (lambda () (repeat 2 (thread-yield)) (set! flag #t)))
+ (thread (call-with-new-thread function default-error-handler)))
+ (not flag)))
+
+ (pass-if "join assignment after yield"
+ (check-feature 'coop-threads)
+ (let* ((flag #f)
+ (function (lambda () (repeat 3 (thread-yield)) (set! flag #t)))
+ (thread (call-with-new-thread function default-error-handler)))
+ (thread-join thread)
+ flag))
+
+ (pass-if "assignment after mutual yield"
+ (check-feature 'coop-threads)
+ (let* ((flag #f)
+ (function (lambda () (repeat 2 (thread-yield)) (set! flag #t)))
+ (thread (call-with-new-thread function default-error-handler)))
+ (repeat 4 (thread-yield))
+ flag))))
+
+
+;;;
+;;; mutecis
+;;;
+
+(with-test-prefix "mutecis"
+
+ (with-test-prefix "make-mutex"
+
+ (expect-fail "documented?"
+ (check-feature 'threads)
+ (documented? "make-mutex")))
+
+ (with-test-prefix "mutex?"
+
+ (expect-fail "documented?"
+ (check-feature 'threads)
+ (documented? "mutex?"))
+
+ (pass-if "new mutex"
+ (check-feature 'threads)
+ (let ((m (make-mutex)))
+ (mutex? m)))
+
+ (pass-if "locked mutex"
+ (check-feature 'threads)
+ (let ((m (make-mutex)))
+ (mutex-lock m)
+ (mutex? m)))
+
+ (pass-if "trylocked mutex"
+ (check-feature 'threads)
+ (let ((m (make-mutex)))
+ (mutex-trylock m)
+ (mutex? m)))
+
+ (pass-if "unlocked mutex"
+ (check-feature 'threads)
+ (let ((m (make-mutex)))
+ (mutex-lock m)
+ (mutex-unlock m)
+ (mutex? m)))
+
+ (pass-if "untrylocked mutex"
+ (check-feature 'threads)
+ (let ((m (make-mutex)))
+ (mutex-trylock m)
+ (mutex-unlock m)
+ (mutex? m)))
+
+ (pass-if "inum"
+ (check-feature 'threads)
+ (not (mutex? 0))))
+
+ (with-test-prefix "mutex-lock"
+
+ (expect-fail "documented?"
+ (check-feature 'threads)
+ (documented? "mutex-lock")))
+
+ (with-test-prefix "mutex-trylock"
+
+ (expect-fail "documented?"
+ (check-feature 'threads)
+ (documented? "mutex-trylock")))
+
+ (with-test-prefix "mutex-unlock"
+
+ (expect-fail "documented?"
+ (check-feature 'threads)
+ (documented? "mutex-unlock")))
+
+ (with-test-prefix "mutex-trylock"
+
+ (pass-if "new mutex"
+ (check-feature 'threads)
+ (let ((m (make-mutex)))
+ (mutex-trylock m)))
+
+ (pass-if "locked mutex"
+ (check-feature 'threads)
+ (let ((m (make-mutex)))
+ (mutex-lock m)
+ (not (mutex-trylock m))))
+
+ (pass-if "trylocked mutex"
+ (check-feature 'threads)
+ (let ((m (make-mutex)))
+ (mutex-trylock m)
+ (not (mutex-trylock m))))
+
+ (pass-if "unlocked mutex"
+ (check-feature 'threads)
+ (let ((m (make-mutex)))
+ (mutex-lock m)
+ (mutex-unlock m)
+ (mutex-trylock m)))
+
+ (pass-if "untrylocked mutex"
+ (check-feature 'threads)
+ (let ((m (make-mutex)))
+ (mutex-trylock m)
+ (mutex-unlock m)
+ (mutex-trylock m)))))
+
+;;;
+;;; condition variables
+;;;
--
- Re: Thread support plan with initial patch, (continued)
- Re: Thread support plan with initial patch, Dirk Herrmann, 2001/04/06
- Re: Thread support plan with initial patch, Mikael Djurfeldt, 2001/04/06
- Re: Thread support plan with initial patch, Marius Vollmer, 2001/04/06
- Re: Thread support plan with initial patch, Mikael Djurfeldt, 2001/04/06
- Re: Thread support plan with initial patch, Dirk Herrmann, 2001/04/10
- Re: Thread support plan with initial patch, NIIBE Yutaka, 2001/04/07
- Re: Thread support plan with initial patch,
NIIBE Yutaka <=
- Re: Thread support plan with initial patch, Mikael Djurfeldt, 2001/04/07
- Re: Thread support plan with initial patch, NIIBE Yutaka, 2001/04/08
- Re: Thread support plan with initial patch, Mikael Djurfeldt, 2001/04/08
- Re: Thread support plan with initial patch, NIIBE Yutaka, 2001/04/09
- Re: Thread support plan with initial patch, Mikael Djurfeldt, 2001/04/09
- Re: Thread support plan with initial patch, Rob Browning, 2001/04/09
- Re: Thread support plan with initial patch, Rob Browning, 2001/04/09
- Re: Thread support plan with initial patch, NIIBE Yutaka, 2001/04/09
- Re: Thread support plan with initial patch, Rob Browning, 2001/04/09
- Re: Thread support plan with initial patch, Dirk Herrmann, 2001/04/10