From 8b0174c879bf74981efe702a00471ed5b8e6912e Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 15 Jan 2009 22:36:28 +0000 Subject: [PATCH 01/21] Don't try to unlock already unlocked heap mutex For each thread that goes into Guile mode, Guile pushes a cleanup function, scm_leave_guile_cleanup, whose purpose is to execute `scm_leave_guile ()' if the thread is terminated while in Guile mode. The problem is that there are various places - like scm_pthread_cond_wait, scm_without_guile and scm_std_select - where the thread temporarily leaves Guile mode (which means unlocking the heap mutex), and the cleanup function is still in place. Therefore if the thread is terminated at these places, the cleanup function ends up trying to unlock a mutex (the heap mutex) which isn't actually locked. * libguile/threads.h (scm_i_thread): New heap_mutex_locked_by_self field. * libguile/threads.c (scm_enter_guile): Set heap_mutex_locked_by_self. (scm_leave_guile): Only unlock if heap_mutex_locked_by_self is 1. (guilify_self_1): Initialize heap_mutex_locked_by_self. (scm_i_thread_sleep_for_gc): Remove incorrect use of t->held_mutex here. --- libguile/threads.c | 18 +++++++++++++++--- libguile/threads.h | 7 +++++++ 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 1d497e72b..27aad3d62 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -409,6 +409,7 @@ scm_enter_guile (scm_t_guile_ticket ticket) if (t) { scm_i_pthread_mutex_lock (&t->heap_mutex); + t->heap_mutex_locked_by_self = 1; resume (t); } } @@ -430,7 +431,11 @@ static scm_t_guile_ticket scm_leave_guile () { scm_i_thread *t = suspend (); - scm_i_pthread_mutex_unlock (&t->heap_mutex); + if (t->heap_mutex_locked_by_self) + { + t->heap_mutex_locked_by_self = 0; + scm_i_pthread_mutex_unlock (&t->heap_mutex); + } return (scm_t_guile_ticket) t; } @@ -491,6 +496,7 @@ guilify_self_1 (SCM_STACKITEM *base) abort (); scm_i_pthread_mutex_init (&t->heap_mutex, NULL); + t->heap_mutex_locked_by_self = 0; scm_i_pthread_mutex_init (&t->admin_mutex, NULL); t->clear_freelists_p = 0; t->gc_running_p = 0; @@ -505,6 +511,7 @@ guilify_self_1 (SCM_STACKITEM *base) scm_i_pthread_setspecific (scm_i_thread_key, t); scm_i_pthread_mutex_lock (&t->heap_mutex); + t->heap_mutex_locked_by_self = 1; scm_i_pthread_mutex_lock (&thread_admin_mutex); t->next_thread = all_threads; @@ -1992,9 +1999,14 @@ void scm_i_thread_sleep_for_gc () { scm_i_thread *t = suspend (); - t->held_mutex = &t->heap_mutex; + + /* Don't put t->heap_mutex in t->held_mutex here, because if the + thread is cancelled during the cond wait, the thread's cleanup + function (scm_leave_guile_cleanup) will handle unlocking the + heap_mutex, so we don't need to do that again in on_thread_exit. + */ scm_i_pthread_cond_wait (&wake_up_cond, &t->heap_mutex); - t->held_mutex = NULL; + resume (t); } diff --git a/libguile/threads.h b/libguile/threads.h index cbff64879..66ddb6aba 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -72,6 +72,13 @@ typedef struct scm_i_thread { */ scm_i_pthread_mutex_t heap_mutex; + /* Boolean tracking whether the above mutex is currently locked by + this thread. This is equivalent to whether or not the thread is + in "Guile mode". This field doesn't need any protection because + it is only ever set or tested by the owning thread. + */ + int heap_mutex_locked_by_self; + /* The freelists of this thread. Each thread has its own lists so that they can all allocate concurrently. */ From 752be95a475132506c35922d284884cf776149d0 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 17 Jan 2009 22:33:36 +0000 Subject: [PATCH 02/21] Remove `INSTALL' * INSTALL: Removed. --- .gitignore | 1 + INSTALL | 291 ----------------------------------------------------- 2 files changed, 1 insertion(+), 291 deletions(-) delete mode 100644 INSTALL diff --git a/.gitignore b/.gitignore index 3df721c2b..7644deacd 100644 --- a/.gitignore +++ b/.gitignore @@ -74,3 +74,4 @@ libguile/stack-limit-calibration.scm cscope.out cscope.files *.log +INSTALL diff --git a/INSTALL b/INSTALL deleted file mode 100644 index 8b82ade08..000000000 --- a/INSTALL +++ /dev/null @@ -1,291 +0,0 @@ -Installation Instructions -************************* - -Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005, -2006, 2007, 2008 Free Software Foundation, Inc. - - This file is free documentation; the Free Software Foundation gives -unlimited permission to copy, distribute and modify it. - -Basic Installation -================== - - Briefly, the shell commands `./configure; make; make install' should -configure, build, and install this package. The following -more-detailed instructions are generic; see the `README' file for -instructions specific to this package. - - The `configure' shell script attempts to guess correct values for -various system-dependent variables used during compilation. It uses -those values to create a `Makefile' in each directory of the package. -It may also create one or more `.h' files containing system-dependent -definitions. Finally, it creates a shell script `config.status' that -you can run in the future to recreate the current configuration, and a -file `config.log' containing compiler output (useful mainly for -debugging `configure'). - - It can also use an optional file (typically called `config.cache' -and enabled with `--cache-file=config.cache' or simply `-C') that saves -the results of its tests to speed up reconfiguring. Caching is -disabled by default to prevent problems with accidental use of stale -cache files. - - If you need to do unusual things to compile the package, please try -to figure out how `configure' could check whether to do them, and mail -diffs or instructions to the address given in the `README' so they can -be considered for the next release. If you are using the cache, and at -some point `config.cache' contains results you don't want to keep, you -may remove or edit it. - - The file `configure.ac' (or `configure.in') is used to create -`configure' by a program called `autoconf'. You need `configure.ac' if -you want to change it or regenerate `configure' using a newer version -of `autoconf'. - -The simplest way to compile this package is: - - 1. `cd' to the directory containing the package's source code and type - `./configure' to configure the package for your system. - - Running `configure' might take a while. While running, it prints - some messages telling which features it is checking for. - - 2. Type `make' to compile the package. - - 3. Optionally, type `make check' to run any self-tests that come with - the package. - - 4. Type `make install' to install the programs and any data files and - documentation. - - 5. You can remove the program binaries and object files from the - source code directory by typing `make clean'. To also remove the - files that `configure' created (so you can compile the package for - a different kind of computer), type `make distclean'. There is - also a `make maintainer-clean' target, but that is intended mainly - for the package's developers. If you use it, you may have to get - all sorts of other programs in order to regenerate files that came - with the distribution. - - 6. Often, you can also type `make uninstall' to remove the installed - files again. - -Compilers and Options -===================== - - Some systems require unusual options for compilation or linking that -the `configure' script does not know about. Run `./configure --help' -for details on some of the pertinent environment variables. - - You can give `configure' initial values for configuration parameters -by setting variables in the command line or in the environment. Here -is an example: - - ./configure CC=c99 CFLAGS=-g LIBS=-lposix - - *Note Defining Variables::, for more details. - -Compiling For Multiple Architectures -==================================== - - You can compile the package for more than one kind of computer at the -same time, by placing the object files for each architecture in their -own directory. To do this, you can use GNU `make'. `cd' to the -directory where you want the object files and executables to go and run -the `configure' script. `configure' automatically checks for the -source code in the directory that `configure' is in and in `..'. - - With a non-GNU `make', it is safer to compile the package for one -architecture at a time in the source code directory. After you have -installed the package for one architecture, use `make distclean' before -reconfiguring for another architecture. - - On MacOS X 10.5 and later systems, you can create libraries and -executables that work on multiple system types--known as "fat" or -"universal" binaries--by specifying multiple `-arch' options to the -compiler but only a single `-arch' option to the preprocessor. Like -this: - - ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ - CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ - CPP="gcc -E" CXXCPP="g++ -E" - - This is not guaranteed to produce working output in all cases, you -may have to build one architecture at a time and combine the results -using the `lipo' tool if you have problems. - -Installation Names -================== - - By default, `make install' installs the package's commands under -`/usr/local/bin', include files under `/usr/local/include', etc. You -can specify an installation prefix other than `/usr/local' by giving -`configure' the option `--prefix=PREFIX'. - - You can specify separate installation prefixes for -architecture-specific files and architecture-independent files. If you -pass the option `--exec-prefix=PREFIX' to `configure', the package uses -PREFIX as the prefix for installing programs and libraries. -Documentation and other data files still use the regular prefix. - - In addition, if you use an unusual directory layout you can give -options like `--bindir=DIR' to specify different values for particular -kinds of files. Run `configure --help' for a list of the directories -you can set and what kinds of files go in them. - - If the package supports it, you can cause programs to be installed -with an extra prefix or suffix on their names by giving `configure' the -option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. - -Optional Features -================= - - Some packages pay attention to `--enable-FEATURE' options to -`configure', where FEATURE indicates an optional part of the package. -They may also pay attention to `--with-PACKAGE' options, where PACKAGE -is something like `gnu-as' or `x' (for the X Window System). The -`README' should mention any `--enable-' and `--with-' options that the -package recognizes. - - For packages that use the X Window System, `configure' can usually -find the X include and library files automatically, but if it doesn't, -you can use the `configure' options `--x-includes=DIR' and -`--x-libraries=DIR' to specify their locations. - -Particular systems -================== - - On HP-UX, the default C compiler is not ANSI C compatible. If GNU -CC is not installed, it is recommended to use the following options in -order to use an ANSI C compiler: - - ./configure CC="cc -Ae" - -and if that doesn't work, install pre-built binaries of GCC for HP-UX. - - On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot -parse its `' header file. The option `-nodtk' can be used as -a workaround. If GNU CC is not installed, it is therefore recommended -to try - - ./configure CC="cc" - -and if that doesn't work, try - - ./configure CC="cc -nodtk" - -Specifying the System Type -========================== - - There may be some features `configure' cannot figure out -automatically, but needs to determine by the type of machine the package -will run on. Usually, assuming the package is built to be run on the -_same_ architectures, `configure' can figure that out, but if it prints -a message saying it cannot guess the machine type, give it the -`--build=TYPE' option. TYPE can either be a short name for the system -type, such as `sun4', or a canonical name which has the form: - - CPU-COMPANY-SYSTEM - -where SYSTEM can have one of these forms: - - OS KERNEL-OS - - See the file `config.sub' for the possible values of each field. If -`config.sub' isn't included in this package, then this package doesn't -need to know the machine type. - - If you are _building_ compiler tools for cross-compiling, you should -use the option `--target=TYPE' to select the type of system they will -produce code for. - - If you want to _use_ a cross compiler, that generates code for a -platform different from the build platform, you should specify the -"host" platform (i.e., that on which the generated programs will -eventually be run) with `--host=TYPE'. - -Sharing Defaults -================ - - If you want to set default values for `configure' scripts to share, -you can create a site shell script called `config.site' that gives -default values for variables like `CC', `cache_file', and `prefix'. -`configure' looks for `PREFIX/share/config.site' if it exists, then -`PREFIX/etc/config.site' if it exists. Or, you can set the -`CONFIG_SITE' environment variable to the location of the site script. -A warning: not all `configure' scripts look for a site script. - -Defining Variables -================== - - Variables not defined in a site shell script can be set in the -environment passed to `configure'. However, some packages may run -configure again during the build, and the customized values of these -variables may be lost. In order to avoid this problem, you should set -them in the `configure' command line, using `VAR=value'. For example: - - ./configure CC=/usr/local2/bin/gcc - -causes the specified `gcc' to be used as the C compiler (unless it is -overridden in the site shell script). - -Unfortunately, this technique does not work for `CONFIG_SHELL' due to -an Autoconf bug. Until the bug is fixed you can use this workaround: - - CONFIG_SHELL=/bin/bash /bin/bash ./configure CONFIG_SHELL=/bin/bash - -`configure' Invocation -====================== - - `configure' recognizes the following options to control how it -operates. - -`--help' -`-h' - Print a summary of all of the options to `configure', and exit. - -`--help=short' -`--help=recursive' - Print a summary of the options unique to this package's - `configure', and exit. The `short' variant lists options used - only in the top level, while the `recursive' variant lists options - also present in any nested packages. - -`--version' -`-V' - Print the version of Autoconf used to generate the `configure' - script, and exit. - -`--cache-file=FILE' - Enable the cache: use and save the results of the tests in FILE, - traditionally `config.cache'. FILE defaults to `/dev/null' to - disable caching. - -`--config-cache' -`-C' - Alias for `--cache-file=config.cache'. - -`--quiet' -`--silent' -`-q' - Do not print messages saying which checks are being made. To - suppress all normal output, redirect it to `/dev/null' (any error - messages will still be shown). - -`--srcdir=DIR' - Look for the package's source code in directory DIR. Usually - `configure' can determine that directory automatically. - -`--prefix=DIR' - Use DIR as the installation prefix. *Note Installation Names:: - for more details, including other options available for fine-tuning - the installation locations. - -`--no-create' -`-n' - Run the configure checks, but stop before creating any output - files. - -`configure' also accepts some other, not widely useful, options. Run -`configure --help' for more details. - From e95d11110b7af0f528404d28209c3a464ab7074d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 18 Jan 2009 12:44:15 +0100 Subject: [PATCH 03/21] Make variables related to the subr table size private and unsigned. * libguile/procs.c (scm_subr_table_size, scm_subr_table_room): Made `static' and `unsigned'. (scm_c_make_subr)[entry]: Made `unsigned'. * libguile/procs.h (scm_subr_table_size, scm_subr_table_room): Remove declarations. --- libguile/procs.c | 6 +++--- libguile/procs.h | 4 +--- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/libguile/procs.c b/libguile/procs.c index 9895548d5..5541671e3 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -44,14 +44,14 @@ scm_t_subr_entry *scm_subr_table; /* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on startup, 786 with guile-readline. 'martin */ -long scm_subr_table_size = 0; -long scm_subr_table_room = 800; +static unsigned long scm_subr_table_size = 0; +static unsigned long scm_subr_table_room = 800; SCM scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) { register SCM z; - long entry; + unsigned long entry; if (scm_subr_table_size == scm_subr_table_room) { diff --git a/libguile/procs.h b/libguile/procs.h index cf9cdf182..8365abec5 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -3,7 +3,7 @@ #ifndef SCM_PROCS_H #define SCM_PROCS_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -131,8 +131,6 @@ typedef struct #define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj) SCM_API scm_t_subr_entry *scm_subr_table; -SCM_API long scm_subr_table_size; -SCM_API long scm_subr_table_room; From 32a2609de06af65341e6b4db6961557b788821e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 18 Jan 2009 12:53:01 +0100 Subject: [PATCH 04/21] Remove useless cooperative multi-threading source files. --- libguile/coop-pthreads.c | 1040 -------------------------------------- libguile/coop-pthreads.h | 81 --- libguile/coop.c | 761 ---------------------------- 3 files changed, 1882 deletions(-) delete mode 100644 libguile/coop-pthreads.c delete mode 100644 libguile/coop-pthreads.h delete mode 100644 libguile/coop.c diff --git a/libguile/coop-pthreads.c b/libguile/coop-pthreads.c deleted file mode 100644 index b1759f9ed..000000000 --- a/libguile/coop-pthreads.c +++ /dev/null @@ -1,1040 +0,0 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * This library 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - - - - -#include "libguile/_scm.h" /* config.h, _scm.h, __scm.h should be first */ - -#include -#include -#include -#include - -#include "libguile/validate.h" -#include "libguile/coop-pthreads.h" -#include "libguile/root.h" -#include "libguile/eval.h" -#include "libguile/async.h" -#include "libguile/ports.h" -#include "libguile/gc.h" - -#undef DEBUG - -/*** Queues */ - -static SCM -make_queue () -{ - return scm_cons (SCM_EOL, SCM_EOL); -} - -static void -enqueue (SCM q, SCM t) -{ - SCM c = scm_cons (t, SCM_EOL); - if (scm_is_null (SCM_CAR (q))) - SCM_SETCAR (q, c); - else - SCM_SETCDR (SCM_CDR (q), c); - SCM_SETCDR (q, c); -} - -static SCM -dequeue (SCM q) -{ - SCM c = SCM_CAR (q); - if (scm_is_null (c)) - return SCM_BOOL_F; - else - { - SCM_SETCAR (q, SCM_CDR (c)); - if (scm_is_null (SCM_CAR (q))) - SCM_SETCDR (q, SCM_EOL); - return SCM_CAR (c); - } -} - - -/*** Threads */ - -typedef struct scm_copt_thread { - - /* A condition variable for sleeping on. - */ - pthread_cond_t sleep_cond; - - /* A link for waiting queues. - */ - struct scm_copt_thread *next_waiting; - - scm_root_state *root; - SCM handle; - pthread_t pthread; - SCM result; - - SCM joining_threads; - - /* For keeping track of the stack and registers. */ - SCM_STACKITEM *base; - SCM_STACKITEM *top; - jmp_buf regs; - -} scm_copt_thread; - -static SCM -make_thread (SCM creation_protects) -{ - SCM z; - scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread"); - z = scm_cell (scm_tc16_thread, (scm_t_bits)t); - t->handle = z; - t->result = creation_protects; - t->base = NULL; - t->joining_threads = make_queue (); - pthread_cond_init (&t->sleep_cond, NULL); - return z; -} - -static void -init_thread_creator (SCM thread, pthread_t th, scm_root_state *r) -{ - scm_copt_thread *t = SCM_THREAD_DATA(thread); - t->root = r; - t->pthread = th; -#ifdef DEBUG - // fprintf (stderr, "%ld created %ld\n", pthread_self (), th); -#endif -} - -static void -init_thread_creatant (SCM thread, SCM_STACKITEM *base) -{ - scm_copt_thread *t = SCM_THREAD_DATA(thread); - t->base = base; - t->top = NULL; -} - -static SCM -thread_mark (SCM obj) -{ - scm_copt_thread *t = SCM_THREAD_DATA (obj); - scm_gc_mark (t->result); - scm_gc_mark (t->joining_threads); - return t->root->handle; -} - -static int -thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) -{ - scm_copt_thread *t = SCM_THREAD_DATA (exp); - scm_puts ("#pthread != -1) - { - scm_putc (' ', port); - scm_intprint (t->pthread, 10, port); - } - else - scm_puts (" (exited)", port); - scm_putc ('>', port); - return 1; -} - -static size_t -thread_free (SCM obj) -{ - scm_copt_thread *t = SCM_THREAD_DATA (obj); - if (t->pthread != -1) - abort (); - scm_gc_free (t, sizeof (*t), "thread"); - return 0; -} - -/*** Fair mutexes */ - -/* POSIX mutexes are not necessarily fair but since we'd like to use a - mutex for scheduling, we build a fair one on top of POSIX. -*/ - -typedef struct fair_mutex { - pthread_mutex_t lock; - scm_copt_thread *owner; - scm_copt_thread *next_waiting, *last_waiting; -} fair_mutex; - -static void -fair_mutex_init (fair_mutex *m) -{ - pthread_mutex_init (&m->lock, NULL); - m->owner = NULL; - m->next_waiting = NULL; - m->last_waiting = NULL; -} - -static void -fair_mutex_lock_1 (fair_mutex *m, scm_copt_thread *t) -{ - if (m->owner == NULL) - m->owner = t; - else - { - t->next_waiting = NULL; - if (m->last_waiting) - m->last_waiting->next_waiting = t; - else - m->next_waiting = t; - m->last_waiting = t; - do - { - pthread_cond_wait (&t->sleep_cond, &m->lock); - } - while (m->owner != t); - assert (m->next_waiting == t); - m->next_waiting = t->next_waiting; - if (m->next_waiting == NULL) - m->last_waiting = NULL; - } - pthread_mutex_unlock (&m->lock); -} - -static void -fair_mutex_lock (fair_mutex *m, scm_copt_thread *t) -{ - pthread_mutex_lock (&m->lock); - fair_mutex_lock_1 (m, t); -} - -static void -fair_mutex_unlock_1 (fair_mutex *m) -{ - scm_copt_thread *t; - pthread_mutex_lock (&m->lock); - // fprintf (stderr, "%ld unlocking\n", m->owner->pthread); - if ((t = m->next_waiting) != NULL) - { - m->owner = t; - pthread_cond_signal (&t->sleep_cond); - } - else - m->owner = NULL; - // fprintf (stderr, "%ld unlocked\n", pthread_self ()); -} - -static void -fair_mutex_unlock (fair_mutex *m) -{ - fair_mutex_unlock_1 (m); - pthread_mutex_unlock (&m->lock); -} - -/* Temporarily give up the mutex. This function makes sure that we - are on the wait queue before starting the next thread. Otherwise - the next thread might preempt us and we will have a hard time - getting on the wait queue. -*/ -#if 0 -static void -fair_mutex_yield (fair_mutex *m) -{ - scm_copt_thread *self, *next; - - pthread_mutex_lock (&m->lock); - - /* get next thread - */ - if ((next = m->next_waiting) == NULL) - { - /* No use giving it up. */ - pthread_mutex_unlock (&m->lock); - return; - } - - /* put us on queue - */ - self = m->owner; - self->next_waiting = NULL; - if (m->last_waiting) - m->last_waiting->next_waiting = self; - else - m->next_waiting = self; - m->last_waiting = self; - - /* wake up next thread - */ - - m->owner = next; - pthread_cond_signal (&next->sleep_cond); - - /* wait for mutex - */ - do - { - pthread_cond_wait (&self->sleep_cond, &m->lock); - } - while (m->owner != self); - assert (m->next_waiting == self); - m->next_waiting = self->next_waiting; - if (m->next_waiting == NULL) - m->last_waiting = NULL; - - pthread_mutex_unlock (&m->lock); -} -#else -static void -fair_mutex_yield (fair_mutex *m) -{ - scm_copt_thread *self = m->owner; - fair_mutex_unlock_1 (m); - fair_mutex_lock_1 (m, self); -} -#endif - -static void -fair_cond_wait (pthread_cond_t *c, fair_mutex *m) -{ - scm_copt_thread *t = m->owner; - fair_mutex_unlock_1 (m); - pthread_cond_wait (c, &m->lock); - fair_mutex_lock_1 (m, t); -} - -/* Return 1 when the mutex was signalled and 0 when not. */ -static int -fair_cond_timedwait (pthread_cond_t *c, fair_mutex *m, scm_t_timespec *at) -{ - int res; - scm_copt_thread *t = m->owner; - fair_mutex_unlock_1 (m); - res = pthread_cond_timedwait (c, &m->lock, at); /* XXX - signals? */ - fair_mutex_lock_1 (m, t); - return res == 0; -} - -/*** Scheduling */ - -/* When a thread wants to execute Guile functions, it locks the - guile_mutex. -*/ - -static fair_mutex guile_mutex; - -static SCM cur_thread; -void *scm_i_copt_thread_data; - -void -scm_i_copt_set_thread_data (void *data) -{ - scm_copt_thread *t = SCM_THREAD_DATA (cur_thread); - scm_i_copt_thread_data = data; - t->root = (scm_root_state *)data; -} - -static void -resume (scm_copt_thread *t) -{ - cur_thread = t->handle; - scm_i_copt_thread_data = t->root; - t->top = NULL; -} - -static void -enter_guile (scm_copt_thread *t) -{ - fair_mutex_lock (&guile_mutex, t); - resume (t); -} - -static scm_copt_thread * -suspend () -{ - SCM cur = cur_thread; - scm_copt_thread *c = SCM_THREAD_DATA (cur); - - /* record top of stack for the GC */ - c->top = (SCM_STACKITEM *)&c; - /* save registers. */ - SCM_FLUSH_REGISTER_WINDOWS; - setjmp (c->regs); - - return c; -} - -static scm_copt_thread * -leave_guile () -{ - scm_copt_thread *c = suspend (); - fair_mutex_unlock (&guile_mutex); - return c; -} - -int scm_i_switch_counter; - -SCM -scm_yield () -{ - /* Testing guile_mutex.next_waiting without locking guile_mutex.lock - is OK since the outcome is not critical. Even when it changes - after the test, we do the right thing. - */ - if (guile_mutex.next_waiting) - { - scm_copt_thread *t = suspend (); - fair_mutex_yield (&guile_mutex); - resume (t); - } - return SCM_BOOL_T; -} - -/* Put the current thread to sleep until it is explicitely unblocked. - */ -static void -block () -{ - scm_copt_thread *t = suspend (); - fair_cond_wait (&t->sleep_cond, &guile_mutex); - resume (t); -} - -/* Put the current thread to sleep until it is explicitely unblocked - or until a signal arrives or until time AT (absolute time) is - reached. Return 1 when it has been unblocked; 0 otherwise. - */ -static int -timed_block (scm_t_timespec *at) -{ - int res; - scm_copt_thread *t = suspend (); - res = fair_cond_timedwait (&t->sleep_cond, &guile_mutex, at); - resume (t); - return res; -} - -/* Unblock a sleeping thread. - */ -static void -unblock (scm_copt_thread *t) -{ - pthread_cond_signal (&t->sleep_cond); -} - -/*** Thread creation */ - -static SCM all_threads; -static int thread_count; - -typedef struct launch_data { - SCM thread; - SCM rootcont; - scm_t_catch_body body; - void *body_data; - scm_t_catch_handler handler; - void *handler_data; -} launch_data; - -static SCM -body_bootstrip (launch_data* data) -{ - /* First save the new root continuation */ - data->rootcont = scm_root->rootcont; - return (data->body) (data->body_data); - // return scm_call_0 (data->body); -} - -static SCM -handler_bootstrip (launch_data* data, SCM tag, SCM throw_args) -{ - scm_root->rootcont = data->rootcont; - return (data->handler) (data->handler_data, tag, throw_args); - // return scm_apply_1 (data->handler, tag, throw_args); -} - -static void -really_launch (SCM_STACKITEM *base, launch_data *data) -{ - SCM thread = data->thread; - scm_copt_thread *t = SCM_THREAD_DATA (thread); - init_thread_creatant (thread, base); - enter_guile (t); - - data->rootcont = SCM_BOOL_F; - t->result = - scm_internal_cwdr ((scm_t_catch_body) body_bootstrip, - data, - (scm_t_catch_handler) handler_bootstrip, - data, base); - free (data); - - pthread_detach (t->pthread); - all_threads = scm_delq (thread, all_threads); - t->pthread = -1; - thread_count--; - leave_guile (); -} - -static void * -launch_thread (void *p) -{ - really_launch ((SCM_STACKITEM *)&p, (launch_data *)p); - return NULL; -} - -static SCM -create_thread (scm_t_catch_body body, void *body_data, - scm_t_catch_handler handler, void *handler_data, - SCM protects) -{ - SCM thread; - - /* Make new thread. The first thing the new thread will do is to - lock guile_mutex. Thus, we can safely complete its - initialization after creating it. While the new thread starts, - all its data is protected via all_threads. - */ - - { - pthread_t th; - SCM root, old_winds; - launch_data *data; - - /* 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); - data = scm_malloc (sizeof (launch_data)); - - /* Make thread. */ - thread = make_thread (protects); - data->thread = thread; - data->body = body; - data->body_data = body_data; - data->handler = handler; - data->handler_data = handler_data; - pthread_create (&th, NULL, launch_thread, (void *) data); - init_thread_creator (thread, th, SCM_ROOT_STATE (root)); - all_threads = scm_cons (thread, all_threads); - thread_count++; - - /* Return to old dynamic context. */ - scm_dowinds (old_winds, - scm_ilength (old_winds)); - } - - return thread; -} - -SCM -scm_call_with_new_thread (SCM argl) -#define FUNC_NAME s_call_with_new_thread -{ - SCM thunk, handler; - - /* Check arguments. */ - { - register SCM args = argl; - if (!scm_is_pair (args)) - SCM_WRONG_NUM_ARGS (); - thunk = SCM_CAR (args); - SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), - thunk, - SCM_ARG1, - s_call_with_new_thread); - args = SCM_CDR (args); - if (!scm_is_pair (args)) - SCM_WRONG_NUM_ARGS (); - handler = SCM_CAR (args); - SCM_ASSERT (scm_is_true (scm_procedure_p (handler)), - handler, - SCM_ARG2, - s_call_with_new_thread); - if (!scm_is_null (SCM_CDR (args))) - SCM_WRONG_NUM_ARGS (); - } - - return create_thread ((scm_t_catch_body) scm_call_0, thunk, - (scm_t_catch_handler) scm_apply_1, handler, - argl); -} -#undef FUNC_NAME - -SCM -scm_spawn_thread (scm_t_catch_body body, void *body_data, - scm_t_catch_handler handler, void *handler_data) -{ - return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F); -} - -/*** Mutexes */ - -/* We implement our own mutex type since we want them to be 'fair', we - want to do fancy things while waiting for them (like running - asyncs) and we want to support waiting on many things at once. - Also, we might add things that are nice for debugging. -*/ - -typedef struct scm_copt_mutex { - /* the thread currently owning the mutex, or SCM_BOOL_F. */ - SCM owner; - /* how much the owner owns us. */ - int level; - /* the threads waiting for this mutex. */ - SCM waiting; -} scm_copt_mutex; - -static SCM -mutex_mark (SCM mx) -{ - scm_copt_mutex *m = SCM_MUTEX_DATA (mx); - scm_gc_mark (m->owner); - return m->waiting; -} - -SCM -scm_make_mutex () -{ - SCM mx = scm_make_smob (scm_tc16_mutex); - scm_copt_mutex *m = SCM_MUTEX_DATA (mx); - m->owner = SCM_BOOL_F; - m->level = 0; - m->waiting = make_queue (); - return mx; -} - -SCM -scm_lock_mutex (SCM mx) -#define FUNC_NAME s_lock_mutex -{ - scm_copt_mutex *m; - SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME); - m = SCM_MUTEX_DATA (mx); - - if (m->owner == SCM_BOOL_F) - m->owner = cur_thread; - else if (m->owner == cur_thread) - m->level++; - else - { - while (m->owner != cur_thread) - { - enqueue (m->waiting, cur_thread); - block (); - SCM_ASYNC_TICK; - } - } - return SCM_BOOL_T; -} -#undef FUNC_NAME - -SCM -scm_try_mutex (SCM mx) -#define FUNC_NAME s_try_mutex -{ - scm_copt_mutex *m; - SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME); - m = SCM_MUTEX_DATA (mx); - - if (m->owner == SCM_BOOL_F) - m->owner = cur_thread; - else if (m->owner == cur_thread) - m->level++; - else - return SCM_BOOL_F; - return SCM_BOOL_T; -} -#undef FUNC_NAME - -SCM -scm_unlock_mutex (SCM mx) -#define FUNC_NAME s_unlock_mutex -{ - scm_copt_mutex *m; - SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME); - m = SCM_MUTEX_DATA (mx); - - if (m->owner != cur_thread) - { - if (m->owner == SCM_BOOL_F) - SCM_MISC_ERROR ("mutex not locked", SCM_EOL); - else - SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL); - } - else if (m->level > 0) - m->level--; - else - { - SCM next = dequeue (m->waiting); - if (scm_is_true (next)) - { - m->owner = next; - unblock (SCM_THREAD_DATA (next)); - scm_yield (); - } - else - m->owner = SCM_BOOL_F; - } - return SCM_BOOL_T; -} -#undef FUNC_NAME - -/*** Condition variables */ - -/* Like mutexes, we implement our own condition variables using the - primitives above. -*/ - -/* yeah, we don't need a structure for this, but more things (like a - name) will likely follow... */ - -typedef struct scm_copt_cond { - /* the threads waiting for this condition. */ - SCM waiting; -} scm_copt_cond; - -static SCM -cond_mark (SCM cv) -{ - scm_copt_cond *c = SCM_CONDVAR_DATA (cv); - return c->waiting; -} - -SCM -scm_make_condition_variable (void) -{ - SCM cv = scm_make_smob (scm_tc16_condvar); - scm_copt_cond *c = SCM_CONDVAR_DATA (cv); - c->waiting = make_queue (); - return cv; -} - -SCM -scm_timed_wait_condition_variable (SCM cv, SCM mx, SCM t) -#define FUNC_NAME s_wait_condition_variable -{ - scm_copt_cond *c; - scm_t_timespec waittime; - int res; - - SCM_ASSERT (SCM_CONDVARP (cv), - cv, - SCM_ARG1, - s_wait_condition_variable); - SCM_ASSERT (SCM_MUTEXP (mx), - mx, - SCM_ARG2, - s_wait_condition_variable); - if (!SCM_UNBNDP (t)) - { - if (scm_is_pair (t)) - { - SCM_VALIDATE_UINT_COPY (3, SCM_CAR(t), waittime.tv_sec); - SCM_VALIDATE_UINT_COPY (3, SCM_CDR(t), waittime.tv_nsec); - waittime.tv_nsec *= 1000; - } - else - { - SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec); - waittime.tv_nsec = 0; - } - } - - c = SCM_CONDVAR_DATA (cv); - - enqueue (c->waiting, cur_thread); - scm_unlock_mutex (mx); - if (SCM_UNBNDP (t)) - { - block (); - res = 1; - } - else - res = timed_block (&waittime); - scm_lock_mutex (mx); - return scm_from_bool (res); -} -#undef FUNC_NAME - -SCM -scm_signal_condition_variable (SCM cv) -#define FUNC_NAME s_signal_condition_variable -{ - SCM th; - scm_copt_cond *c; - SCM_ASSERT (SCM_CONDVARP (cv), - cv, - SCM_ARG1, - s_signal_condition_variable); - c = SCM_CONDVAR_DATA (cv); - if (scm_is_true (th = dequeue (c->waiting))) - unblock (SCM_THREAD_DATA (th)); - return SCM_BOOL_T; -} -#undef FUNC_NAME - -SCM -scm_broadcast_condition_variable (SCM cv) -#define FUNC_NAME s_broadcast_condition_variable -{ - SCM th; - scm_copt_cond *c; - SCM_ASSERT (SCM_CONDVARP (cv), - cv, - SCM_ARG1, - s_signal_condition_variable); - c = SCM_CONDVAR_DATA (cv); - while (scm_is_true (th = dequeue (c->waiting))) - unblock (SCM_THREAD_DATA (th)); - return SCM_BOOL_T; -} -#undef FUNC_NAME - -/*** Initialization */ - -void -scm_threads_init (SCM_STACKITEM *base) -{ - scm_tc16_thread = scm_make_smob_type ("thread", 0); - scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_copt_mutex)); - scm_tc16_condvar = scm_make_smob_type ("condition-variable", - sizeof (scm_copt_cond)); - - scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT; - - fair_mutex_init (&guile_mutex); - - cur_thread = make_thread (SCM_BOOL_F); - enter_guile (SCM_THREAD_DATA (cur_thread)); - /* root is set later from init.c */ - init_thread_creator (cur_thread, pthread_self(), NULL); - init_thread_creatant (cur_thread, base); - - thread_count = 1; - scm_gc_register_root (&all_threads); - all_threads = scm_cons (cur_thread, SCM_EOL); - - scm_set_smob_mark (scm_tc16_thread, thread_mark); - scm_set_smob_print (scm_tc16_thread, thread_print); - scm_set_smob_free (scm_tc16_thread, thread_free); - - scm_set_smob_mark (scm_tc16_mutex, mutex_mark); - - scm_set_smob_mark (scm_tc16_condvar, cond_mark); -} - -/*** Marking stacks */ - -/* XXX - what to do with this? Do we need to handle this for blocked - threads as well? -*/ -#ifdef __ia64__ -# define SCM_MARK_BACKING_STORE() do { \ - ucontext_t ctx; \ - SCM_STACKITEM * top, * bot; \ - getcontext (&ctx); \ - scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \ - ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \ - / sizeof (SCM_STACKITEM))); \ - bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base (); \ - top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \ - scm_mark_locations (bot, top - bot); } while (0) -#else -# define SCM_MARK_BACKING_STORE() -#endif - -void -scm_threads_mark_stacks (void) -{ - volatile SCM c; - for (c = all_threads; !scm_is_null (c); c = SCM_CDR (c)) - { - scm_copt_thread *t = SCM_THREAD_DATA (SCM_CAR (c)); - if (t->base == NULL) - { - /* Not fully initialized yet. */ - continue; - } - if (t->top == NULL) - { - /* Active thread */ - /* stack_len is long rather than sizet in order to guarantee - that &stack_len is long aligned */ -#if SCM_STACK_GROWS_UP - long stack_len = ((SCM_STACKITEM *) (&t) - - (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, - ((size_t) sizeof scm_save_regs_gc_mark - / sizeof (SCM_STACKITEM))); - - scm_mark_locations (((size_t) t->base, - (sizet) stack_len)); -#else - long stack_len = ((SCM_STACKITEM *) t->base - - (SCM_STACKITEM *) (&t)); - - /* 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, - ((size_t) sizeof scm_save_regs_gc_mark - / sizeof (SCM_STACKITEM))); - - scm_mark_locations ((SCM_STACKITEM *) &t, - stack_len); -#endif - } - else - { - /* Suspended thread */ -#if SCM_STACK_GROWS_UP - long stack_len = t->top - t->base; - scm_mark_locations (t->base, stack_len); -#else - long stack_len = t->base - t->top; - scm_mark_locations (t->top, stack_len); -#endif - scm_mark_locations ((SCM_STACKITEM *) t->regs, - ((size_t) sizeof(t->regs) - / sizeof (SCM_STACKITEM))); - } - } -} - -/*** Select */ - -int -scm_internal_select (int nfds, - SELECT_TYPE *readfds, - SELECT_TYPE *writefds, - SELECT_TYPE *exceptfds, - struct timeval *timeout) -{ - int res, eno; - scm_copt_thread *c = leave_guile (); - res = select (nfds, readfds, writefds, exceptfds, timeout); - eno = errno; - enter_guile (c); - SCM_ASYNC_TICK; - errno = eno; - return res; -} - -void -scm_init_iselect () -{ -} - -unsigned long -scm_thread_usleep (unsigned long usec) -{ - scm_copt_thread *c = leave_guile (); - usleep (usec); - enter_guile (c); - return 0; -} - -unsigned long -scm_thread_sleep (unsigned long sec) -{ - unsigned long res; - scm_copt_thread *c = leave_guile (); - res = sleep (sec); - enter_guile (c); - return res; -} - -/*** Misc */ - -SCM -scm_current_thread (void) -{ - return cur_thread; -} - -SCM -scm_all_threads (void) -{ - return all_threads; -} - -scm_root_state * -scm_i_thread_root (SCM thread) -{ - if (thread == cur_thread) - return scm_i_copt_thread_data; - else - return ((scm_copt_thread *)SCM_THREAD_DATA (thread))->root; -} - -SCM -scm_join_thread (SCM thread) -#define FUNC_NAME s_join_thread -{ - scm_copt_thread *t; - SCM res; - - SCM_VALIDATE_THREAD (1, thread); - - t = SCM_THREAD_DATA (thread); - if (t->pthread != -1) - { - scm_copt_thread *c = leave_guile (); - pthread_join (t->pthread, NULL); - enter_guile (c); - } - res = t->result; - t->result = SCM_BOOL_F; - return res; -} -#undef FUNC_NAME - -int -scm_c_thread_exited_p (SCM thread) -#define FUNC_NAME s_scm_thread_exited_p -{ - scm_copt_thread *t; - SCM_VALIDATE_THREAD (1, thread); - t = SCM_THREAD_DATA (thread); - return t->pthread == -1; -} -#undef FUNC_NAME - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ - diff --git a/libguile/coop-pthreads.h b/libguile/coop-pthreads.h deleted file mode 100644 index cc1f75a9b..000000000 --- a/libguile/coop-pthreads.h +++ /dev/null @@ -1,81 +0,0 @@ -/* classes: h_files */ - -#ifndef SCM_COOP_PTHREADS_H -#define SCM_COOP_PTHREADS_H - -/* Copyright (C) 2002, 2006, 2008 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * This library 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - - - -/* The coop-pthreads implementation. We use pthreads for the basic - multi threading stuff, but rig it so that only one thread is ever - active inside Guile. -*/ - -#include - -#include "libguile/iselect.h" - -#if (SCM_ENABLE_DEPRECATED == 1) - -/* Thread local data support --- generic C API */ - -typedef pthread_key_t scm_t_key; - -#define scm_key_create pthread_key_create -#define scm_setspecific pthread_setspecific -#define scm_getspecific pthread_getspecific -#define scm_key_delete pthread_key_delete - -#endif /* SCM_ENABLE_DEPRECATED == 1 */ - -/* Since only one thread can be active anyway, we don't need to do - anything special around critical sections. In fact, that's the - reason we do only support cooperative threading: Guile's critical - regions have not been completely identified yet. (I think.) */ - -#define SCM_CRITICAL_SECTION_START -#define SCM_CRITICAL_SECTION_END - -#define SCM_I_THREAD_SWITCH_COUNT 50 - -#define SCM_THREAD_SWITCHING_CODE \ -do { \ - scm_i_switch_counter--; \ - if (scm_i_switch_counter == 0) \ - { \ - scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT; \ - scm_yield(); \ - } \ -} while (0) - -SCM_API int scm_i_switch_counter; - -#define SCM_THREAD_LOCAL_DATA (scm_i_copt_thread_data) -#define SCM_SET_THREAD_LOCAL_DATA(ptr) (scm_i_copt_set_thread_data (ptr)) - -SCM_API void *scm_i_copt_thread_data; -SCM_INTERNAL void scm_i_copt_set_thread_data (void *data); - -#endif /* SCM_COOP_PTHREAD_H */ - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/coop.c b/libguile/coop.c deleted file mode 100644 index 08e586ff0..000000000 --- a/libguile/coop.c +++ /dev/null @@ -1,761 +0,0 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2006 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * This library 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - - -/* $Id: coop.c,v 1.39 2006-04-17 00:05:38 kryde Exp $ */ - -/* Cooperative thread library, based on QuickThreads */ - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include - -#ifdef HAVE_UNISTD_H -#include -#endif - -#include - -#include "qt/qt.h" -#include "libguile/eval.h" - - /* #define COOP_STKSIZE (0x10000) */ -#define COOP_STKSIZE (scm_eval_stack) - -/* `alignment' must be a power of 2. */ -#define COOP_STKALIGN(sp, alignment) \ -((void *)((((qt_word_t)(sp)) + (alignment) - 1) & ~((alignment)-1))) - - - -/* Queue access functions. */ - -static void -coop_qinit (coop_q_t *q) -{ - q->t.next = q->tail = &q->t; - - q->t.all_prev = NULL; - q->t.all_next = NULL; - q->t.nfds = 0; - q->t.readfds = NULL; - q->t.writefds = NULL; - q->t.exceptfds = NULL; - q->t.timeoutp = 0; -} - - -coop_t * -coop_qget (coop_q_t *q) -{ - coop_t *t; - - t = q->t.next; - q->t.next = t->next; - if (t->next == &q->t) - { - if (t == &q->t) - { /* If it was already empty .. */ - return NULL; /* .. say so. */ - } - q->tail = &q->t; /* Else now it is empty. */ - } - return (t); -} - - -void -coop_qput (coop_q_t *q, coop_t *t) -{ - q->tail->next = t; - t->next = &q->t; - q->tail = t; -} - -static void -coop_all_qput (coop_q_t *q, coop_t *t) -{ - if (q->t.all_next) - q->t.all_next->all_prev = t; - t->all_prev = NULL; - t->all_next = q->t.all_next; - q->t.all_next = t; -} - -static void -coop_all_qremove (coop_q_t *q, coop_t *t) -{ - if (t->all_prev) - t->all_prev->all_next = t->all_next; - else - q->t.all_next = t->all_next; - if (t->all_next) - t->all_next->all_prev = t->all_prev; -} - -/* 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 -coop_timeout_qinsert (coop_q_t *q, coop_t *t) -{ - coop_t *pred = &q->t; - int sec = t->wakeup_time.tv_sec; - int usec = t->wakeup_time.tv_usec; - while (pred->next != &q->t - && pred->next->timeoutp - && (pred->next->wakeup_time.tv_sec < sec - || (pred->next->wakeup_time.tv_sec == sec - && pred->next->wakeup_time.tv_usec < usec))) - pred = pred->next; - t->next = pred->next; - pred->next = t; - if (t->next == &q->t) - q->tail = t; -} - - - -/* 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 */ -coop_q_t coop_global_allq; /* A queue of all threads. */ -static coop_t coop_global_main; /* Thread for the process. */ -coop_t *coop_global_curr; /* Currently-executing thread. */ - -#ifdef GUILE_PTHREAD_COMPAT -static coop_q_t coop_deadq; -static int coop_quitting_p = -1; -static pthread_cond_t coop_cond_quit; -static pthread_cond_t coop_cond_create; -static pthread_mutex_t coop_mutex_create; -static pthread_t coop_mother; -static int mother_awake_p = 0; -static coop_t *coop_child; -#endif - -static void *coop_starthelp (qt_t *old, void *ignore0, void *ignore1); -static void coop_only (void *pu, void *pt, qt_userf_t *f); -static void *coop_aborthelp (qt_t *sp, void *old, void *null); -static void *coop_yieldhelp (qt_t *sp, void *old, void *blockq); - - -/* called on process termination. */ -#ifdef HAVE_ATEXIT -static void -coop_finish (void) -#else -#ifdef HAVE_ON_EXIT -extern int on_exit (void (*procp) (), int arg); - -static void -coop_finish (int status, void *arg) -#else -#error Dont know how to setup a cleanup handler on your system. -#endif -#endif -{ -#ifdef GUILE_PTHREAD_COMPAT - coop_quitting_p = 1; - pthread_cond_signal (&coop_cond_create); - pthread_cond_broadcast (&coop_cond_quit); -#endif -} - -void -coop_init () -{ - coop_qinit (&coop_global_runq); - coop_qinit (&coop_global_sleepq); - coop_qinit (&coop_tmp_queue); - coop_qinit (&coop_global_allq); - coop_global_curr = &coop_global_main; -#ifdef GUILE_PTHREAD_COMPAT - coop_qinit (&coop_deadq); - pthread_cond_init (&coop_cond_quit, NULL); - pthread_cond_init (&coop_cond_create, NULL); - pthread_mutex_init (&coop_mutex_create, NULL); -#endif -#ifdef HAVE_ATEXIT - atexit (coop_finish); -#else -#ifdef HAVE_ON_EXIT - on_exit (coop_finish, 0); -#endif -#endif -} - -void -coop_start() -{ - coop_t *next; - - while ((next = coop_qget (&coop_global_runq)) != NULL) { - coop_global_curr = next; - QT_BLOCK (coop_starthelp, 0, 0, next->sp); - } -} - - -static void * -coop_starthelp (qt_t *old, void *ignore0, void *ignore1) -{ - coop_global_main.sp = old; - coop_global_main.joining = NULL; - coop_qput (&coop_global_runq, &coop_global_main); - return NULL; /* not used, but keeps compiler happy */ -} - -int -coop_mutex_init (coop_m *m) -{ - return coop_new_mutex_init (m, NULL); -} - -int -coop_new_mutex_init (coop_m *m, coop_mattr *attr) -{ - m->owner = NULL; - m->level = 0; - coop_qinit(&(m->waiting)); - return 0; -} - -int -coop_mutex_trylock (coop_m *m) -{ - if (m->owner == NULL) - { - m->owner = coop_global_curr; - return 0; - } - else if (m->owner == coop_global_curr) - { - m->level++; - return 0; - } - else - return EBUSY; -} - -int -coop_mutex_lock (coop_m *m) -{ - if (m->owner == NULL) - { - m->owner = coop_global_curr; - } - else if (m->owner == coop_global_curr) - { - m->level++; - } - else - { - coop_t *old, *newthread; - - /* Record the current top-of-stack before going to sleep */ - coop_global_curr->top = &old; - - newthread = coop_wait_for_runnable_thread(); - if (newthread == coop_global_curr) - coop_abort (); - old = coop_global_curr; - coop_global_curr = newthread; - QT_BLOCK (coop_yieldhelp, old, &(m->waiting), newthread->sp); - } - return 0; -} - - -int -coop_mutex_unlock (coop_m *m) -{ - coop_t *old, *newthread; - - if (m->level == 0) - { - newthread = coop_qget (&(m->waiting)); - if (newthread != NULL) - { - /* Record the current top-of-stack before going to sleep */ - coop_global_curr->top = &old; - - old = coop_global_curr; - coop_global_curr = newthread; - /* The new thread came into m->waiting through a lock operation. - It now owns this mutex. */ - m->owner = coop_global_curr; - QT_BLOCK (coop_yieldhelp, old, &coop_global_runq, newthread->sp); - } - else - { - m->owner = NULL; - } - } - else if (m->level > 0) - m->level--; - else - abort (); /* XXX */ - - return 0; -} - - -int -coop_mutex_destroy (coop_m *m) -{ - return 0; -} - - -int -coop_condition_variable_init (coop_c *c) -{ - return coop_new_condition_variable_init (c, NULL); -} - -int -coop_new_condition_variable_init (coop_c *c, coop_cattr *a) -{ - coop_qinit(&(c->waiting)); - return 0; -} - -int -coop_condition_variable_wait_mutex (coop_c *c, coop_m *m) -{ - coop_t *old, *newthread; - - /* coop_mutex_unlock (m); */ - newthread = coop_qget (&(m->waiting)); - if (newthread != NULL) - { - m->owner = newthread; - } - else - { - m->owner = NULL; - /*fixme* Should we really wait here? Isn't it OK just to proceed? */ - newthread = coop_wait_for_runnable_thread(); - if (newthread == coop_global_curr) - coop_abort (); - } - coop_global_curr->top = &old; - old = coop_global_curr; - coop_global_curr = newthread; - QT_BLOCK (coop_yieldhelp, old, &(c->waiting), newthread->sp); - - coop_mutex_lock (m); - return 0; -} - -int -coop_condition_variable_timed_wait_mutex (coop_c *c, - coop_m *m, - const scm_t_timespec *abstime) -{ - coop_t *old, *t; -#ifdef ETIMEDOUT - int res = ETIMEDOUT; -#elif defined (WSAETIMEDOUT) - int res = WSAETIMEDOUT; -#else - int res = 0; -#endif - - /* coop_mutex_unlock (m); */ - t = coop_qget (&(m->waiting)); - if (t != NULL) - { - m->owner = t; - } - else - { - m->owner = NULL; - coop_global_curr->timeoutp = 1; - coop_global_curr->wakeup_time.tv_sec = abstime->tv_sec; - coop_global_curr->wakeup_time.tv_usec = abstime->tv_nsec / 1000; - coop_timeout_qinsert (&coop_global_sleepq, coop_global_curr); - t = coop_wait_for_runnable_thread(); - } - if (t != coop_global_curr) - { - coop_global_curr->top = &old; - old = coop_global_curr; - coop_global_curr = t; - QT_BLOCK (coop_yieldhelp, old, &(c->waiting), t->sp); - - /* Are we still in the sleep queue? */ - old = &coop_global_sleepq.t; - for (t = old->next; t != &coop_global_sleepq.t; old = t, t = t->next) - if (t == coop_global_curr) - { - old->next = t->next; /* unlink */ - res = 0; - break; - } - } - coop_mutex_lock (m); - return res; -} - -int -coop_condition_variable_broadcast (coop_c *c) -{ - coop_t *newthread; - - while ((newthread = coop_qget (&(c->waiting))) != NULL) - { - coop_qput (&coop_global_runq, newthread); - } - return 0; -} - -int -coop_condition_variable_signal (coop_c *c) -{ - return coop_condition_variable_broadcast (c); -} - - -/* {Keys} - */ - -static int n_keys = 0; -static int max_keys = 0; -static void (**destructors) (void *) = 0; - -int -coop_key_create (coop_k *keyp, void (*destructor) (void *value)) -{ - if (n_keys >= max_keys) - { - int i; - max_keys = max_keys ? max_keys * 3 / 2 : 10; - destructors = realloc (destructors, sizeof (void *) * max_keys); - if (destructors == 0) - { - fprintf (stderr, "Virtual memory exceeded in coop_key_create\n"); - exit (1); - } - for (i = n_keys; i < max_keys; ++i) - destructors[i] = NULL; - } - destructors[n_keys] = destructor; - *keyp = n_keys++; - return 0; -} - -int -coop_setspecific (coop_k key, const void *value) -{ - int n_keys = coop_global_curr->n_keys; - if (key >= n_keys) - { - int i; - coop_global_curr->n_keys = max_keys; - coop_global_curr->specific = realloc (n_keys - ? coop_global_curr->specific - : NULL, - sizeof (void *) * max_keys); - if (coop_global_curr->specific == 0) - { - fprintf (stderr, "Virtual memory exceeded in coop_setspecific\n"); - exit (1); - } - for (i = n_keys; i < max_keys; ++i) - coop_global_curr->specific[i] = NULL; - } - coop_global_curr->specific[key] = (void *) value; - return 0; -} - -void * -coop_getspecific (coop_k key) -{ - return (key < coop_global_curr->n_keys - ? coop_global_curr->specific[key] - : NULL); -} - -int -coop_key_delete (coop_k key) -{ - return 0; -} - - -int -coop_condition_variable_destroy (coop_c *c) -{ - return 0; -} - -#ifdef GUILE_PTHREAD_COMPAT - -/* 1K room for the cond wait routine */ -#if SCM_STACK_GROWS_UP -# define COOP_STACK_ROOM (256) -#else -# define COOP_STACK_ROOM (-256) -#endif - -static void * -dummy_start (void *coop_thread) -{ - coop_t *t = (coop_t *) coop_thread; - int res; - t->sp = (qt_t *) (&t + COOP_STACK_ROOM); - pthread_mutex_init (&t->dummy_mutex, NULL); - pthread_mutex_lock (&t->dummy_mutex); - coop_child = 0; - do - res = pthread_cond_wait (&coop_cond_quit, &t->dummy_mutex); - while (res == EINTR); - return 0; -} - -static void * -mother (void *dummy) -{ - pthread_mutex_lock (&coop_mutex_create); - while (!coop_quitting_p) - { - int res; - pthread_create (&coop_child->dummy_thread, - NULL, - dummy_start, - coop_child); - mother_awake_p = 0; - do - res = pthread_cond_wait (&coop_cond_create, &coop_mutex_create); - while (res == EINTR); - } - return 0; -} - -#endif - -coop_t * -coop_create (coop_userf_t *f, void *pu) -{ - coop_t *t; -#ifndef GUILE_PTHREAD_COMPAT - void *sto; -#endif - -#ifdef GUILE_PTHREAD_COMPAT - t = coop_qget (&coop_deadq); - if (t) - { - t->sp = t->base; - t->specific = 0; - t->n_keys = 0; - } - else -#endif - { - t = scm_malloc (sizeof (coop_t)); - t->specific = NULL; - t->n_keys = 0; -#ifdef GUILE_PTHREAD_COMPAT - coop_child = t; - mother_awake_p = 1; - if (coop_quitting_p < 0) - { - coop_quitting_p = 0; - /* We can't create threads ourselves since the pthread - * corresponding to this stack might be sleeping. - */ - pthread_create (&coop_mother, NULL, mother, NULL); - } - else - { - pthread_cond_signal (&coop_cond_create); - } - /* We can't use a pthreads condition variable since "this" - * pthread could already be asleep. We can't use a COOP - * condition variable because they are not safe against - * pre-emptive switching. - */ - while (coop_child || mother_awake_p) - usleep (0); -#else - t->sto = scm_malloc (COOP_STKSIZE); - sto = COOP_STKALIGN (t->sto, QT_STKALIGN); - t->sp = QT_SP (sto, COOP_STKSIZE - QT_STKALIGN); -#endif - t->base = t->sp; - } - t->sp = QT_ARGS (t->sp, pu, t, (qt_userf_t *)f, coop_only); - t->joining = NULL; - coop_qput (&coop_global_runq, t); - coop_all_qput (&coop_global_allq, t); - - return t; -} - - -static void -coop_only (void *pu, void *pt, qt_userf_t *f) -{ - coop_global_curr = (coop_t *)pt; - (*(coop_userf_t *)f)(pu); - coop_abort(); - /* NOTREACHED */ -} - - -void -coop_abort () -{ - coop_t *old, *newthread; - - /* Wake up any threads that are waiting to join this one */ - if (coop_global_curr->joining) - { - while ((newthread = coop_qget ((coop_q_t *)(coop_global_curr->joining))) - != NULL) - { - coop_qput (&coop_global_runq, newthread); - } - free (coop_global_curr->joining); - } - - scm_I_am_dead = 1; - do { - newthread = coop_wait_for_runnable_thread(); - } while (newthread == coop_global_curr); - scm_I_am_dead = 0; - coop_all_qremove (&coop_global_allq, coop_global_curr); - old = coop_global_curr; - coop_global_curr = newthread; - QT_ABORT (coop_aborthelp, old, (void *) NULL, newthread->sp); -} - - -static void * -coop_aborthelp (qt_t *sp, void *old, void *null) -{ - coop_t *oldthread = (coop_t *) old; - - if (oldthread->specific) - free (oldthread->specific); -#ifndef GUILE_PTHREAD_COMPAT - free (oldthread->sto); - free (oldthread); -#else - coop_qput (&coop_deadq, oldthread); -#endif - - return NULL; -} - - -void -coop_join(coop_t *t) -{ - coop_t *old, *newthread; - - /* Create a join list if necessary */ - if (t->joining == NULL) - { - t->joining = scm_malloc(sizeof(coop_q_t)); - coop_qinit((coop_q_t *) t->joining); - } - - newthread = coop_wait_for_runnable_thread(); - if (newthread == coop_global_curr) - return; - old = coop_global_curr; - coop_global_curr = newthread; - QT_BLOCK (coop_yieldhelp, old, (coop_q_t *) t->joining, newthread->sp); -} - -void -coop_yield() -{ - coop_t *old = NULL; - coop_t *newthread; - - newthread = coop_next_runnable_thread(); - - /* There may be no other runnable threads. Return if this is the - case. */ - if (newthread == coop_global_curr) - return; - - old = coop_global_curr; - - coop_global_curr = newthread; - QT_BLOCK (coop_yieldhelp, old, &coop_global_runq, newthread->sp); -} - - -static void * -coop_yieldhelp (qt_t *sp, void *old, void *blockq) -{ - ((coop_t *)old)->sp = sp; - coop_qput ((coop_q_t *)blockq, (coop_t *)old); - return NULL; -} - -/* Replacement for the system's sleep() function. Does the right thing - for the process - but not for the system (it busy-waits) */ - -void * -coop_sleephelp (qt_t *sp, void *old, void *blockq) -{ - ((coop_t *)old)->sp = sp; - /* old is already on the sleep queue - so there's no need to - do anything extra here */ - return NULL; -} - -unsigned long -scm_thread_usleep (unsigned long usec) -{ - 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... :) */ -} - -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_internal_select (0, NULL, NULL, NULL, &timeout); - slept = time (NULL) - now; - return slept > sec ? 0 : sec - slept; -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ From cbee5075d69cb057c4af4c5e24319da90367897f Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 23 Jan 2009 01:02:46 +0000 Subject: [PATCH 05/21] Fix MinGW HAVE_STRUCT_TIMESPEC build problem Reported by Carlo Bramini. See the comment in _scm.h. * THANKS: Add Carlo Bramini. * libguile/_scm.h: Undefine HAVE_STRUCT_TIMESPEC. --- NEWS | 1 + THANKS | 1 + libguile/_scm.h | 19 +++++++++++++++++++ 3 files changed, 21 insertions(+) diff --git a/NEWS b/NEWS index 8471a500b..9a160301c 100644 --- a/NEWS +++ b/NEWS @@ -46,6 +46,7 @@ Changes in 1.8.7 (since 1.8.6) * Bugs fixed ** Fix %fast-slot-ref/set!, to avoid possible segmentation fault +** Fix MinGW build problem caused by HAVE_STRUCT_TIMESPEC confusion Changes in 1.8.6 (since 1.8.5) diff --git a/THANKS b/THANKS index 3b3b91443..48bdd0e2f 100644 --- a/THANKS +++ b/THANKS @@ -23,6 +23,7 @@ For fixes or providing information which led to a fix: David Allouche Martin Baulig Fabrice Bauzac + Carlo Bramini Rob Browning Adrian Bunk Michael Carmack diff --git a/libguile/_scm.h b/libguile/_scm.h index 6b728be2b..e40f29bb0 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -38,6 +38,25 @@ # include #endif +/* Undefine HAVE_STRUCT_TIMESPEC, because the libguile C code doesn't + need it anymore, and because on MinGW: + + - the definition of struct timespec is provided (if at all) by + pthread.h + + - pthread.h will _not_ define struct timespec if + HAVE_STRUCT_TIMESPEC is 1, because then it thinks that it doesn't + need to. + + The libguile C code doesn't need HAVE_STRUCT_TIMESPEC anymore, + because the value of HAVE_STRUCT_TIMESPEC has already been + incorporated in how scm_t_timespec is defined (in scmconfig.h), and + the rest of the libguile C code now just uses scm_t_timespec. + */ +#ifdef HAVE_STRUCT_TIMESPEC +#undef HAVE_STRUCT_TIMESPEC +#endif + #include #include "libguile/__scm.h" From ab878b0f8e675a741a7dd56f52638a7cc0419907 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 23 Jan 2009 01:26:16 +0000 Subject: [PATCH 06/21] Fix build when scm_t_timespec is different from struct timespec Reported by Roland Haeder. The declaration and definition of scm_pthread_cond_timedwait were using possibly different types for the third arg. * THANKS: Added Roland Haeder. * libguile/threads.h (scm_pthread_cond_timedwait): Use scm_t_timespec for third arg rather than struct timespec, for consistency with the function implementation. --- NEWS | 1 + THANKS | 1 + libguile/threads.h | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 9a160301c..cb71150e0 100644 --- a/NEWS +++ b/NEWS @@ -47,6 +47,7 @@ Changes in 1.8.7 (since 1.8.6) ** Fix %fast-slot-ref/set!, to avoid possible segmentation fault ** Fix MinGW build problem caused by HAVE_STRUCT_TIMESPEC confusion +** Fix build problem when scm_t_timespec is different from struct timespec Changes in 1.8.6 (since 1.8.5) diff --git a/THANKS b/THANKS index 48bdd0e2f..a0fbb8ea2 100644 --- a/THANKS +++ b/THANKS @@ -43,6 +43,7 @@ For fixes or providing information which led to a fix: John Goerzen Mike Gran Szavai Gyula + Roland Haeder Sven Hartrumpf Eric Hanchrow Sam Hocevar diff --git a/libguile/threads.h b/libguile/threads.h index 66ddb6aba..e2abf2648 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -232,7 +232,7 @@ SCM_API int scm_pthread_cond_wait (pthread_cond_t *cond, pthread_mutex_t *mutex); SCM_API int scm_pthread_cond_timedwait (pthread_cond_t *cond, pthread_mutex_t *mutex, - const struct timespec *abstime); + const scm_t_timespec *abstime); #endif /* More convenience functions. From 4f7a0504aac215832e99290e31c9944795c5d206 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 27 Jan 2009 13:43:07 +0100 Subject: [PATCH 07/21] merge in from guile-lib: add some extensibility to `help' * ice-9/session.scm (add-value-help-handler!) (remove-value-help-handler!, add-name-help-handler!) (remove-name-help-handler!): New public interfaces, to allow some basic extensibility of the help interface. Merged in from guile-lib's (scheme session). --- ice-9/session.scm | 72 +++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 64 insertions(+), 8 deletions(-) diff --git a/ice-9/session.scm b/ice-9/session.scm index 1c9f48016..6971a7894 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -20,12 +20,61 @@ :use-module (ice-9 documentation) :use-module (ice-9 regex) :use-module (ice-9 rdelim) - :export (help apropos apropos-internal apropos-fold - apropos-fold-accessible apropos-fold-exported apropos-fold-all - source arity system-module)) + :export (help + add-value-help-handler! remove-value-help-handler! + add-name-help-handler! remove-name-help-handler! + apropos apropos-internal apropos-fold apropos-fold-accessible + apropos-fold-exported apropos-fold-all source arity + system-module module-commentary)) +(define *value-help-handlers* '()) + +(define (add-value-help-handler! proc) + "Adds a handler for performing `help' on a value. + +`proc' will be called as (PROC NAME VALUE). `proc' should return #t to +indicate that it has performed help, a string to override the default +object documentation, or #f to try the other handlers, potentially +falling back on the normal behavior for `help'." + (set! *value-help-handlers* (cons proc *value-help-handlers*))) + +(define (remove-value-help-handler! proc) + "Removes a handler for performing `help' on a value. + +See the documentation for `add-value-help-handler' for more +information." + (set! *value-help-handlers* (delete! proc *value-help-handlers*))) + +(define (try-value-help name value) + (or-map (lambda (proc) (proc name value)) *value-help-handlers*)) + + +(define *name-help-handlers* '()) + +(define (add-name-help-handler! proc) + "Adds a handler for performing `help' on a name. + +`proc' will be called with the unevaluated name as its argument. That is +to say, when the user calls `(help FOO)', the name is FOO, exactly as +the user types it. + +The return value of `proc' is as specified in +`add-value-help-handler!'." + (set! *name-help-handlers* (cons proc *name-help-handlers*))) + +(define (remove-name-help-handler! proc) + "Removes a handler for performing `help' on a name. + +See the documentation for `add-name-help-handler' for more +information." + (set! *name-help-handlers* (delete! proc *name-help-handlers*))) + +(define (try-name-help name) + (or-map (lambda (proc) (proc name)) *name-help-handlers*)) + + ;;; Documentation ;;; (define help @@ -45,6 +94,10 @@ You don't seem to have regular expressions installed.\n")) type x)))) (cond + ;; User-specified + ((try-name-help name) + => (lambda (x) (if (not (eq? x #t)) (display x)))) + ;; SYMBOL ((symbol? name) (help-doc name @@ -60,10 +113,12 @@ You don't seem to have regular expressions installed.\n")) ((and (list? name) (= (length name) 2) (eq? (car name) 'unquote)) - (cond ((object-documentation - (local-eval (cadr name) env)) - => write-line) - (else (not-found 'documentation (cadr name))))) + (let ((value (local-eval (cadr name) env))) + (cond ((try-value-help (cadr name) value) + => noop) + ((object-documentation value) + => write-line) + (else (not-found 'documentation (cadr name)))))) ;; (quote SYMBOL) ((and (list? name) @@ -109,7 +164,8 @@ You don't seem to have regular expressions installed.\n")) (let ((entries (apropos-fold (lambda (module name object data) (cons (list module name - (object-documentation object) + (or (try-value-help name object) + (object-documentation object)) (cond ((closure? object) "a procedure") ((procedure? object) From 53d81399bef1d9396665e79fb6b9c25eb8e2a6ad Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Jan 2009 11:56:21 +0100 Subject: [PATCH 08/21] cleanups to value and help help handlers * ice-9/session.scm (*value-help-handlers*): Define object-documentation as the default value help handler. (remove-value-help-handler!, add-name-help-handler!) (remove-name-help-handler!): Fix docs. (help, help-doc): Fix so that we try object-documentation through try-value-help, and we obey the docs regarding what happens with return values. --- ice-9/session.scm | 33 ++++++++++++++------------------- 1 file changed, 14 insertions(+), 19 deletions(-) diff --git a/ice-9/session.scm b/ice-9/session.scm index 6971a7894..c1bbab206 100644 --- a/ice-9/session.scm +++ b/ice-9/session.scm @@ -29,7 +29,9 @@ -(define *value-help-handlers* '()) +(define *value-help-handlers* + `(,(lambda (name value) + (object-documentation value)))) (define (add-value-help-handler! proc) "Adds a handler for performing `help' on a value. @@ -41,10 +43,7 @@ falling back on the normal behavior for `help'." (set! *value-help-handlers* (cons proc *value-help-handlers*))) (define (remove-value-help-handler! proc) - "Removes a handler for performing `help' on a value. - -See the documentation for `add-value-help-handler' for more -information." + "Removes a handler for performing `help' on a value." (set! *value-help-handlers* (delete! proc *value-help-handlers*))) (define (try-value-help name value) @@ -60,15 +59,13 @@ information." to say, when the user calls `(help FOO)', the name is FOO, exactly as the user types it. -The return value of `proc' is as specified in -`add-value-help-handler!'." +`proc' should return #t to indicate that it has performed help, a string +to override the default object documentation, or #f to try the other +handlers, potentially falling back on the normal behavior for `help'." (set! *name-help-handlers* (cons proc *name-help-handlers*))) (define (remove-name-help-handler! proc) - "Removes a handler for performing `help' on a name. - -See the documentation for `add-name-help-handler' for more -information." + "Removes a handler for performing `help' on a name." (set! *name-help-handlers* (delete! proc *name-help-handlers*))) (define (try-name-help name) @@ -113,12 +110,11 @@ You don't seem to have regular expressions installed.\n")) ((and (list? name) (= (length name) 2) (eq? (car name) 'unquote)) - (let ((value (local-eval (cadr name) env))) - (cond ((try-value-help (cadr name) value) - => noop) - ((object-documentation value) - => write-line) - (else (not-found 'documentation (cadr name)))))) + (let ((doc (try-value-help (cadr name) + (local-eval (cadr name) env)))) + (cond ((not doc) (not-found 'documentation (cadr name))) + ((eq? doc #t)) ;; pass + (else (write-line doc))))) ;; (quote SYMBOL) ((and (list? name) @@ -164,8 +160,7 @@ You don't seem to have regular expressions installed.\n")) (let ((entries (apropos-fold (lambda (module name object data) (cons (list module name - (or (try-value-help name object) - (object-documentation object)) + (try-value-help name object) (cond ((closure? object) "a procedure") ((procedure? object) From c010924a71f942100dc7b4021d5ef1c6decf9c85 Mon Sep 17 00:00:00 2001 From: Julian Graham Date: Tue, 20 Jan 2009 10:25:04 -0500 Subject: [PATCH 09/21] Update SRFI-11 docs to use correct name for let*-values. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Ludovic Courtès --- doc/ref/srfi-modules.texi | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index b1fdde1c3..1fa50b209 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -29,7 +29,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-8:: receive. * SRFI-9:: define-record-type. * SRFI-10:: Hash-Comma Reader Extension. -* SRFI-11:: let-values and let-values*. +* SRFI-11:: let-values and let*-values. * SRFI-13:: String library. * SRFI-14:: Character-set library. * SRFI-16:: case-lambda @@ -1514,9 +1514,9 @@ the anonymous and compact syntax of @nicode{#,()} is much better. @cindex SRFI-11 @findex let-values -@findex let-values* +@findex let*-values This module implements the binding forms for multiple values -@code{let-values} and @code{let-values*}. These forms are similar to +@code{let-values} and @code{let*-values}. These forms are similar to @code{let} and @code{let*} (@pxref{Local Bindings}), but they support binding of the values returned by multiple-valued expressions. @@ -1533,7 +1533,7 @@ available. @code{let-values} performs all bindings simultaneously, which means that no expression in the binding clauses may refer to variables bound in the -same clause list. @code{let-values*}, on the other hand, performs the +same clause list. @code{let*-values}, on the other hand, performs the bindings sequentially, just like @code{let*} does for single-valued expressions. From 202271f291971cf14175f5a1a193955f72d43d79 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 18 Jan 2009 16:42:17 +0100 Subject: [PATCH 10/21] Publish the maximum number of SMOB types as `SCM_I_MAX_SMOB_TYPE_COUNT'. * libguile/goops.c (create_smob_classes): Refer to `SCM_I_MAX_SMOB_TYPE_COUNT' rather than 255 (which is wrong) or 256. * libguile/smob.c (MAX_SMOB_COUNT): Alias for `SCM_I_MAX_SMOB_TYPE_COUNT'. * libguile/smob.h (SCM_I_MAX_SMOB_TYPE_COUNT): New macro. --- libguile/goops.c | 4 ++-- libguile/smob.c | 5 +++-- libguile/smob.h | 5 ++++- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index b3dfe0d69..84bfc0275 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2694,8 +2694,8 @@ create_smob_classes (void) { long i; - scm_smob_class = (SCM *) scm_malloc (255 * sizeof (SCM)); - for (i = 0; i < 255; ++i) + scm_smob_class = scm_malloc (SCM_I_MAX_SMOB_TYPE_COUNT * sizeof (SCM)); + for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i) scm_smob_class[i] = 0; scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword; diff --git a/libguile/smob.c b/libguile/smob.c index cbbc24e27..2e781ed1e 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -45,7 +45,8 @@ * tags for smobjects (if you know a tag you can get an index and conversely). */ -#define MAX_SMOB_COUNT 256 +#define MAX_SMOB_COUNT SCM_I_MAX_SMOB_TYPE_COUNT + long scm_numsmob; scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT]; diff --git a/libguile/smob.h b/libguile/smob.h index a4d70c8be..7aab3e74f 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -3,7 +3,7 @@ #ifndef SCM_SMOB_H #define SCM_SMOB_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -112,6 +112,9 @@ do { \ #define SCM_SMOB_APPLY_2(x, a1, a2) (SCM_SMOB_DESCRIPTOR (x).apply_2 (x, (a1), (a2))) #define SCM_SMOB_APPLY_3(x, a1, a2, rst) (SCM_SMOB_DESCRIPTOR (x).apply_3 (x, (a1), (a2), (rst))) +/* Maximum number of SMOB types. */ +#define SCM_I_MAX_SMOB_TYPE_COUNT 256 + SCM_API long scm_numsmob; SCM_API scm_smob_descriptor scm_smobs[]; From 04795a1cb259c20896fb2edb50c58086027281b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 18 Jan 2009 16:53:01 +0100 Subject: [PATCH 11/21] GOOPS: Statically allocate the SMOB class array. * libguile/goops.c (scm_smob_class): Statically allocate it. (create_smob_classes): Don't malloc(3) `scm_smob_class'. * libguile/goops.h (scm_smob_class): Update declaration. * libguile/smob.c (scm_make_smob_type, scm_set_smob_apply): When checking whether GOOPS is initialized, check whether the first element of SCM_SMOB_CLASS is non-zero. --- libguile/goops.c | 3 +-- libguile/goops.h | 4 ++-- libguile/smob.c | 6 +++--- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index 84bfc0275..17944418b 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -153,7 +153,7 @@ SCM scm_class_scm; SCM scm_class_int, scm_class_float, scm_class_double; SCM *scm_port_class = 0; -SCM *scm_smob_class = 0; +SCM scm_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT]; SCM scm_no_applicable_method; @@ -2694,7 +2694,6 @@ create_smob_classes (void) { long i; - scm_smob_class = scm_malloc (SCM_I_MAX_SMOB_TYPE_COUNT * sizeof (SCM)); for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i) scm_smob_class[i] = 0; diff --git a/libguile/goops.h b/libguile/goops.h index 6b88ae267..545dac3d3 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -3,7 +3,7 @@ #ifndef SCM_GOOPS_H #define SCM_GOOPS_H -/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -169,7 +169,7 @@ SCM_API SCM scm_class_integer; SCM_API SCM scm_class_fraction; SCM_API SCM scm_class_unknown; SCM_API SCM *scm_port_class; -SCM_API SCM *scm_smob_class; +SCM_API SCM scm_smob_class[]; SCM_API SCM scm_class_top; SCM_API SCM scm_class_object; SCM_API SCM scm_class_class; diff --git a/libguile/smob.c b/libguile/smob.c index 2e781ed1e..899197901 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -309,7 +309,7 @@ scm_make_smob_type (char const *name, size_t size) } /* Make a class object if Goops is present. */ - if (scm_smob_class) + if (SCM_UNPACK (scm_smob_class[0]) != 0) scm_smob_class[new_smob] = scm_make_extended_class (name, 0); return scm_tc7_smob + new_smob * 256; @@ -449,8 +449,8 @@ scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (), scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2; scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3; scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type; - - if (scm_smob_class) + + if (SCM_UNPACK (scm_smob_class[0]) != 0) scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]); } From 5bb2d903b9e54fdd5858a16ba11fa91a9dc0c692 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 18 Jan 2009 18:47:20 +0100 Subject: [PATCH 12/21] Publish the maximum number of port types as `SCM_I_MAX_PORT_TYPE_COUNT'. * libguile/goops.c (create_port_classes): Use `SCM_I_MAX_PORT_TYPE_COUNT' instead of a hard-wired 256. * libguile/objects.h (SCM_OUT_PCLASS_INDEX, SCM_INOUT_PCLASS_INDEX): Likewise. * libguile/ports.c (scm_make_port_type): Likewise. * libguile/ports.h (SCM_I_MAX_PORT_TYPE_COUNT): New macro. --- libguile/goops.c | 7 ++++--- libguile/objects.h | 8 ++++---- libguile/ports.c | 4 ++-- libguile/ports.h | 5 ++++- 4 files changed, 14 insertions(+), 10 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index 17944418b..831ab819e 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2738,9 +2738,10 @@ create_port_classes (void) { long i; - scm_port_class = (SCM *) scm_malloc (3 * 256 * sizeof (SCM)); - for (i = 0; i < 3 * 256; ++i) - scm_port_class[i] = 0; + /* Allocate 3 times the maximum number of port types so that input ports, + output ports, and in/out ports can be stored at different offsets. See + `SCM_IN_PCLASS_INDEX' et al. */ + scm_port_class = scm_calloc (3 * SCM_I_MAX_PORT_TYPE_COUNT * sizeof (SCM)); for (i = 0; i < scm_numptob; ++i) scm_make_port_classes (i, SCM_PTOBNAME (i)); diff --git a/libguile/objects.h b/libguile/objects.h index 68996d2a0..9b2a0ed5a 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -3,7 +3,7 @@ #ifndef SCM_OBJECTS_H #define SCM_OBJECTS_H -/* Copyright (C) 1996,1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1996,1999,2000,2001, 2003, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -171,9 +171,9 @@ typedef struct scm_effective_slot_definition { #define SCM_CMETHOD_ENV(cmethod) SCM_CAR (cmethod) /* Port classes */ -#define SCM_IN_PCLASS_INDEX 0x000 -#define SCM_OUT_PCLASS_INDEX 0x100 -#define SCM_INOUT_PCLASS_INDEX 0x200 +#define SCM_IN_PCLASS_INDEX 0 +#define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT +#define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT) /* Plugin proxy classes for basic types. */ SCM_API SCM scm_metaclass_standard; diff --git a/libguile/ports.c b/libguile/ports.c index 2b7677220..dc412a445 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -136,7 +136,7 @@ scm_make_port_type (char *name, void (*write) (SCM port, const void *data, size_t size)) { char *tmp; - if (255 <= scm_numptob) + if (SCM_I_MAX_PORT_TYPE_COUNT - 1 <= scm_numptob) goto ptoberr; SCM_CRITICAL_SECTION_START; SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, diff --git a/libguile/ports.h b/libguile/ports.h index 084a55500..cb9d9d2d5 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -3,7 +3,7 @@ #ifndef SCM_PORTS_H #define SCM_PORTS_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -162,6 +162,9 @@ SCM_INTERNAL SCM scm_i_port_weak_hash; #define SCM_DECCOL(port) {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;} #define SCM_TABCOL(port) {SCM_COL (port) += 8 - SCM_COL (port) % 8;} +/* Maximum number of port types. */ +#define SCM_I_MAX_PORT_TYPE_COUNT 256 + /* port-type description. */ From 6290d3f10927f887102a164ccb1a7291cc62288d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 18 Jan 2009 20:21:44 +0100 Subject: [PATCH 13/21] GOOPS: Statically allocate the PORT class array. * libguile/goops.c (scm_port_class): Statically allocate it. (create_port_classes): Don't use `scm_calloc ()'. * libguile/goops.h (scm_port_class): Update declaration. * libguile/ports.c (scm_make_port_type): When checking whether GOOPS is initialized, check whether the first element of SCM_PORT_CLASS is non-zero. --- libguile/goops.c | 12 ++++++------ libguile/goops.h | 2 +- libguile/ports.c | 2 +- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index 831ab819e..827dbfb33 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -152,7 +152,12 @@ SCM scm_class_protected_opaque, scm_class_protected_read_only; SCM scm_class_scm; SCM scm_class_int, scm_class_float, scm_class_double; -SCM *scm_port_class = 0; +/* Port classes. Allocate 3 times the maximum number of port types so that + input ports, output ports, and in/out ports can be stored at different + offsets. See `SCM_IN_PCLASS_INDEX' et al. */ +SCM scm_port_class[3 * SCM_I_MAX_PORT_TYPE_COUNT]; + +/* SMOB classes. */ SCM scm_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT]; SCM scm_no_applicable_method; @@ -2738,11 +2743,6 @@ create_port_classes (void) { long i; - /* Allocate 3 times the maximum number of port types so that input ports, - output ports, and in/out ports can be stored at different offsets. See - `SCM_IN_PCLASS_INDEX' et al. */ - scm_port_class = scm_calloc (3 * SCM_I_MAX_PORT_TYPE_COUNT * sizeof (SCM)); - for (i = 0; i < scm_numptob; ++i) scm_make_port_classes (i, SCM_PTOBNAME (i)); } diff --git a/libguile/goops.h b/libguile/goops.h index 545dac3d3..0dc0cd238 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -168,7 +168,7 @@ SCM_API SCM scm_class_complex; SCM_API SCM scm_class_integer; SCM_API SCM scm_class_fraction; SCM_API SCM scm_class_unknown; -SCM_API SCM *scm_port_class; +SCM_API SCM scm_port_class[]; SCM_API SCM scm_smob_class[]; SCM_API SCM scm_class_top; SCM_API SCM scm_class_object; diff --git a/libguile/ports.c b/libguile/ports.c index dc412a445..1f49708c8 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -172,7 +172,7 @@ scm_make_port_type (char *name, scm_memory_error ("scm_make_port_type"); } /* Make a class object if Goops is present */ - if (scm_port_class) + if (SCM_UNPACK (scm_port_class[0]) != 0) scm_make_port_classes (scm_numptob - 1, SCM_PTOBNAME (scm_numptob - 1)); return scm_tc7_port + (scm_numptob - 1) * 256; } From 95a040cd2be7ad03bf197edbdb1fec2c52749ef6 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 5 Feb 2009 22:03:53 +0000 Subject: [PATCH 14/21] Fix build when compiled with -Wundef -Werror (Reported by David Fang) * libguile/inline.h: Check if __APPLE_CC__ is defined before testing its value. --- NEWS | 1 + THANKS | 1 + libguile/inline.h | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index cb71150e0..4502765a2 100644 --- a/NEWS +++ b/NEWS @@ -48,6 +48,7 @@ Changes in 1.8.7 (since 1.8.6) ** Fix %fast-slot-ref/set!, to avoid possible segmentation fault ** Fix MinGW build problem caused by HAVE_STRUCT_TIMESPEC confusion ** Fix build problem when scm_t_timespec is different from struct timespec +** Fix build when compiled with -Wundef -Werror Changes in 1.8.6 (since 1.8.5) diff --git a/THANKS b/THANKS index a0fbb8ea2..1d90462ee 100644 --- a/THANKS +++ b/THANKS @@ -36,6 +36,7 @@ For fixes or providing information which led to a fix: Nils Durner John W Eaton Clinton Ebadi + David Fang Charles Gagnon Peter Gavin Eric Gillespie, Jr diff --git a/libguile/inline.h b/libguile/inline.h index f3c76b5e2..6fbde7910 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -54,7 +54,7 @@ C99 mode and doesn't define `__GNUC_STDC_INLINE__'. Fall back to "static inline" in that case. */ -# if (defined __GNUC__) && (!(__APPLE_CC__ > 5400 && __STDC_VERSION__ >= 199901L)) +# if (defined __GNUC__) && (!(((defined __APPLE_CC__) && (__APPLE_CC__ > 5400)) && __STDC_VERSION__ >= 199901L)) # define SCM_C_USE_EXTERN_INLINE 1 # if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2) # define SCM_C_EXTERN_INLINE \ From ad5f5ada1d50ecdab634d60ffe3a13b9193156aa Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 5 Feb 2009 22:11:26 +0000 Subject: [PATCH 15/21] Allow @ to work with (ice-9 syncase) (Reported by Panicz Maciej Godek.) * test-suite/tests/syncase.test ("@ works with syncase"): New test. * ice-9/syncase.scm (guile-macro): When a Guile macro transformer produces a variable, don't pass it through sc-expand. --- NEWS | 7 +++++++ THANKS | 1 + ice-9/syncase.scm | 8 +++++--- test-suite/tests/syncase.test | 3 +++ 4 files changed, 16 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 4502765a2..2d9916c5d 100644 --- a/NEWS +++ b/NEWS @@ -50,6 +50,13 @@ Changes in 1.8.7 (since 1.8.6) ** Fix build problem when scm_t_timespec is different from struct timespec ** Fix build when compiled with -Wundef -Werror +** Allow @ macro to work with (ice-9 syncase) + +Previously, use of the @ macro in a module whose code is being +transformed by (ice-9 syncase) would cause an "Invalid syntax" error. +Now it works as you would expect (giving the value of the specified +module binding). + Changes in 1.8.6 (since 1.8.5) diff --git a/THANKS b/THANKS index 1d90462ee..d93837d3b 100644 --- a/THANKS +++ b/THANKS @@ -41,6 +41,7 @@ For fixes or providing information which led to a fix: Peter Gavin Eric Gillespie, Jr Didier Godefroy + Panicz Maciej Godek John Goerzen Mike Gran Szavai Gyula diff --git a/ice-9/syncase.scm b/ice-9/syncase.scm index 6ee4d166e..39cf27372 100644 --- a/ice-9/syncase.scm +++ b/ice-9/syncase.scm @@ -146,9 +146,11 @@ (let ((e ((macro-transformer m) e (append r (list eval-closure))))) - (if (null? r) - (sc-expand e) - (sc-chi e r w)))))))))) + (if (variable? e) + e + (if (null? r) + (sc-expand e) + (sc-chi e r w))))))))))) (define generated-symbols (make-weak-key-hash-table 1019)) diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test index 1184f7b54..c681fc381 100644 --- a/test-suite/tests/syncase.test +++ b/test-suite/tests/syncase.test @@ -34,3 +34,6 @@ (pass-if "basic syncase macro" (= (plus 1 2 3) (+ 1 2 3))) + +(pass-if "@ works with syncase" + (eq? run-test (@ (test-suite lib) run-test))) From 4c9e29ec38350a5206aa3e8e72ad4376512ada2b Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 9 Feb 2009 21:51:31 +0000 Subject: [PATCH 16/21] Clean lib-version.texi * doc/ref/Makefile.am (CLEANFILES): Add lib-version.texi. --- doc/ref/Makefile.am | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 19458cfee..2ca550ab3 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -98,9 +98,12 @@ lib-version.texi: $(top_srcdir)/GUILE-VERSION MAINTAINERCLEANFILES = autoconf-macros.texi # To allow "make distcheck" to succeed, lib-version.texi must either -# be cleaned or be included in the distribution. There's no point -# forcing a distribution build to regenerate lib-version.texi, because -# it can't possibly be different on the build machine than where the -# distribution was generated, so we might as well include it in the -# distribution. +# be cleaned or be included in the distribution. Or both - and in +# fact both are good. There's no point forcing a distribution build +# to regenerate lib-version.texi, because it can't possibly be +# different on the build machine than where the distribution was +# generated, so we might as well include it in the distribution. EXTRA_DIST += lib-version.texi +# But when we want to get back to a clean tree, lib-version.texi +# should be cleaned. +CLEANFILES = lib-version.texi From cce8b2ce93703aff953750fb40cb53176ea66504 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 20 Jan 2009 21:24:41 +0100 Subject: [PATCH 17/21] Use `SCM_SNAME ()' when requesting the name of a subr. * libguile/gsubr.c (create_gsubr, create_gsubr_with_generic): Use `SCM_SNAME ()' instead of `SCM_SUBR_ENTRY (subr).name'. * libguile/procs.c (scm_c_define_subr_with_generic, scm_makcclo): Likewise. (scm_c_make_subr_with_generic): Same with `SCM_SUBR_GENERIC ()'. --- libguile/gsubr.c | 8 ++++---- libguile/procs.c | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/libguile/gsubr.c b/libguile/gsubr.c index be5c34271..fdb70ed92 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -75,13 +75,13 @@ create_gsubr (int define, const char *name, subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn); create_subr: if (define) - scm_define (SCM_SUBR_ENTRY(subr).name, subr); + scm_define (SCM_SNAME (subr), subr); return subr; default: { SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L); SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn); - SCM sym = SCM_SUBR_ENTRY(subr).name; + SCM sym = SCM_SNAME (subr); if (SCM_GSUBR_MAX < req + opt + rst) { fprintf (stderr, @@ -151,7 +151,7 @@ create_gsubr_with_generic (int define, subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf); create_subr: if (define) - scm_define (SCM_SUBR_ENTRY(subr).name, subr); + scm_define (SCM_SNAME (subr), subr); return subr; default: ; diff --git a/libguile/procs.c b/libguile/procs.c index 5541671e3..acd7e4663 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -78,7 +78,7 @@ SCM scm_c_define_subr (const char *name, long type, SCM (*fcn) ()) { SCM subr = scm_c_make_subr (name, type, fcn); - scm_define (SCM_SUBR_ENTRY(subr).name, subr); + scm_define (SCM_SNAME (subr), subr); return subr; } @@ -99,7 +99,7 @@ scm_c_make_subr_with_generic (const char *name, long type, SCM (*fcn) (), SCM *gf) { SCM subr = scm_c_make_subr (name, type, fcn); - SCM_SUBR_ENTRY(subr).generic = gf; + SCM_SUBR_GENERIC (subr) = gf; return subr; } @@ -108,7 +108,7 @@ scm_c_define_subr_with_generic (const char *name, long type, SCM (*fcn) (), SCM *gf) { SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf); - scm_define (SCM_SUBR_ENTRY(subr).name, subr); + scm_define (SCM_SNAME (subr), subr); return subr; } From feccd2d3100fd2964d4c2df58ab3da7ce4949a66 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 20 Jan 2009 23:29:09 +0100 Subject: [PATCH 18/21] Add `SCM_SET_SUBR_GENERIC ()' to replace `SCM_SUBR_GENERIC ()' as an lvalue. * libguile/goops.c (scm_c_extend_primitive_generic): Use `SCM_SET_SUBR_GENERIC ()' instead of using `SCM_SUBR_GENERIC ()' as an lvalue. * libguile/procs.c (scm_c_make_subr_with_generic): Use `SCM_SET_SUBR_GENERIC_LOC ()'. * libguile/procs.h (SCM_SET_SUBR_GENERIC, SCM_SET_SUBR_GENERIC_LOC): New macros. --- libguile/goops.c | 2 +- libguile/procs.c | 2 +- libguile/procs.h | 2 ++ 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index 827dbfb33..4e6458697 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1902,7 +1902,7 @@ scm_c_extend_primitive_generic (SCM extended, SCM extension) gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic), gf, SCM_SNAME (extension)); - *SCM_SUBR_GENERIC (extension) = gext; + SCM_SET_SUBR_GENERIC (extension, gext); } else { diff --git a/libguile/procs.c b/libguile/procs.c index acd7e4663..854ddba22 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -99,7 +99,7 @@ scm_c_make_subr_with_generic (const char *name, long type, SCM (*fcn) (), SCM *gf) { SCM subr = scm_c_make_subr (name, type, fcn); - SCM_SUBR_GENERIC (subr) = gf; + SCM_SET_SUBR_GENERIC_LOC (subr, gf); return subr; } diff --git a/libguile/procs.h b/libguile/procs.h index 8365abec5..6f8d4c21a 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -50,6 +50,8 @@ typedef struct #define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x)) #define SCM_SUBR_PROPS(x) (SCM_SUBR_ENTRY (x).properties) #define SCM_SUBR_GENERIC(x) (SCM_SUBR_ENTRY (x).generic) +#define SCM_SET_SUBR_GENERIC(x, g) (*SCM_SUBR_ENTRY (x).generic = (g)) +#define SCM_SET_SUBR_GENERIC_LOC(x, g) (SCM_SUBR_ENTRY (x).generic = (g)) #define SCM_CCLO_LENGTH(x) (SCM_CELL_WORD_0 (x) >> 8) #define SCM_MAKE_CCLO_TAG(v) (((v) << 8) + scm_tc7_cclo) From ac51e74b9533cc3df8fe9656b97a6385a6e71b80 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 12 Feb 2009 00:02:11 +0100 Subject: [PATCH 19/21] Use double-cells to store subrs. * libguile/procs.c (scm_subr_table, scm_subr_table_size, scm_subr_table_room, subr_table_gc_hint, scm_init_subr_table, scm_mark_subr_table): Remove. (scm_c_make_subr): Simply return a double-cell, with the procedure name and properties stored in a two-element array. (scm_free_subr_entry): Free the meta-info slot. * libguile/init.c (scm_i_init_guile): Remove call to `scm_init_subr_table ()'. * libguile/procs.h (SCM_SUBR_META_INFO): New macro. (SCM_SNAME, SCM_SUBR_PROPS): Use it. (SCM_SUBR_GENERIC, SCM_SET_SUBR_GENERIC, SCM_SET_SUBR_GENERIC_LOC): Update. (scm_t_subr_entry, SCM_SUBR_ENTRY, SCM_SUBRNUM, scm_subr_table, scm_mark_subr_table, scm_init_subr_table): Remove. --- libguile/gc-mark.c | 4 +-- libguile/init.c | 3 +-- libguile/procs.c | 65 ++++++++++------------------------------------ libguile/procs.h | 28 +++++--------------- 4 files changed, 21 insertions(+), 79 deletions(-) diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c index 9afafbac3..e73f6e10e 100644 --- a/libguile/gc-mark.c +++ b/libguile/gc-mark.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -99,8 +99,6 @@ scm_mark_all (void) } } } - - scm_mark_subr_table (); loops = 0; while (1) diff --git a/libguile/init.c b/libguile/init.c index 522bec901..60c83c5fb 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -444,7 +444,6 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_struct_prehistory (); /* requires storage */ scm_symbols_prehistory (); /* requires storage */ - scm_init_subr_table (); #if 0 scm_environments_prehistory (); /* requires storage */ #endif diff --git a/libguile/procs.c b/libguile/procs.c index 854ddba22..e36e7ca16 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -37,40 +37,26 @@ /* {Procedures} */ -scm_t_subr_entry *scm_subr_table; /* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */ /* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on startup, 786 with guile-readline. 'martin */ -static unsigned long scm_subr_table_size = 0; -static unsigned long scm_subr_table_room = 800; - -SCM +SCM scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) { register SCM z; - unsigned long entry; + SCM *meta_info; - if (scm_subr_table_size == scm_subr_table_room) - { - long new_size = scm_subr_table_room * 3 / 2; - void *new_table - = scm_realloc ((char *) scm_subr_table, - sizeof (scm_t_subr_entry) * new_size); - scm_subr_table = new_table; - scm_subr_table_room = new_size; - } + meta_info = scm_gc_malloc (2 * sizeof (* meta_info), + "subr meta-info"); + meta_info[0] = scm_from_locale_symbol (name); + meta_info[1] = SCM_EOL; /* properties */ + + z = scm_double_cell ((scm_t_bits) type, (scm_t_bits) fcn, + 0 /* generic */, (scm_t_bits) meta_info); - entry = scm_subr_table_size; - z = scm_cell ((entry << 8) + type, (scm_t_bits) fcn); - scm_subr_table[entry].handle = z; - scm_subr_table[entry].name = scm_from_locale_symbol (name); - scm_subr_table[entry].generic = 0; - scm_subr_table[entry].properties = SCM_EOL; - scm_subr_table_size++; - return z; } @@ -87,11 +73,8 @@ scm_c_define_subr (const char *name, long type, SCM (*fcn) ()) void scm_free_subr_entry (SCM subr) { - long entry = SCM_SUBRNUM (subr); - /* Move last entry in table to the free position */ - scm_subr_table[entry] = scm_subr_table[scm_subr_table_size - 1]; - SCM_SET_SUBRNUM (scm_subr_table[entry].handle, entry); - scm_subr_table_size--; + scm_gc_free (SCM_SUBR_META_INFO (subr), 2 * sizeof (SCM), + "subr meta-info"); } SCM @@ -112,20 +95,6 @@ scm_c_define_subr_with_generic (const char *name, return subr; } -void -scm_mark_subr_table () -{ - long i; - for (i = 0; i < scm_subr_table_size; ++i) - { - scm_gc_mark (scm_subr_table[i].name); - if (scm_subr_table[i].generic && *scm_subr_table[i].generic) - scm_gc_mark (*scm_subr_table[i].generic); - if (SCM_NIMP (scm_subr_table[i].properties)) - scm_gc_mark (scm_subr_table[i].properties); - } -} - #ifdef CCLO SCM @@ -348,15 +317,7 @@ scm_setter (SCM proc) return SCM_BOOL_F; /* not reached */ } - -void -scm_init_subr_table () -{ - scm_subr_table - = ((scm_t_subr_entry *) - scm_malloc (sizeof (scm_t_subr_entry) * scm_subr_table_room)); -} - + void scm_init_procs () { diff --git a/libguile/procs.h b/libguile/procs.h index 6f8d4c21a..f0c0ee363 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -30,28 +30,15 @@ /* Subrs */ -typedef struct -{ - SCM handle; /* link back to procedure object */ - SCM name; - SCM *generic; /* 0 if no generic support - * *generic == 0 until first method - */ - SCM properties; /* procedure properties */ -} scm_t_subr_entry; - -#define SCM_SUBRNUM(subr) (SCM_CELL_WORD_0 (subr) >> 8) -#define SCM_SET_SUBRNUM(subr, num) \ - SCM_SET_CELL_WORD_0 (subr, (num << 8) + SCM_TYP7 (subr)) -#define SCM_SUBR_ENTRY(x) (scm_subr_table[SCM_SUBRNUM (x)]) -#define SCM_SNAME(x) (SCM_SUBR_ENTRY (x).name) +#define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x)) +#define SCM_SNAME(x) (SCM_SUBR_META_INFO (x) [0]) #define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x)) #define SCM_SET_SUBRF(x, v) (SCM_SET_CELL_WORD_1 ((x), (v))) #define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x)) -#define SCM_SUBR_PROPS(x) (SCM_SUBR_ENTRY (x).properties) -#define SCM_SUBR_GENERIC(x) (SCM_SUBR_ENTRY (x).generic) -#define SCM_SET_SUBR_GENERIC(x, g) (*SCM_SUBR_ENTRY (x).generic = (g)) -#define SCM_SET_SUBR_GENERIC_LOC(x, g) (SCM_SUBR_ENTRY (x).generic = (g)) +#define SCM_SUBR_PROPS(x) (SCM_SUBR_META_INFO (x) [1]) +#define SCM_SUBR_GENERIC(x) ((SCM *) SCM_CELL_WORD_2 (x)) +#define SCM_SET_SUBR_GENERIC(x, g) (*((SCM *) SCM_CELL_WORD_2 (x)) = (g)) +#define SCM_SET_SUBR_GENERIC_LOC(x, g) (SCM_SET_CELL_WORD_2 (x, (scm_t_bits) g)) #define SCM_CCLO_LENGTH(x) (SCM_CELL_WORD_0 (x) >> 8) #define SCM_MAKE_CCLO_TAG(v) (((v) << 8) + scm_tc7_cclo) @@ -132,11 +119,9 @@ typedef struct #define SCM_PROCEDURE(obj) SCM_CELL_OBJECT_1 (obj) #define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj) -SCM_API scm_t_subr_entry *scm_subr_table; -SCM_API void scm_mark_subr_table (void); SCM_API void scm_free_subr_entry (SCM subr); SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)()); SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type, @@ -154,7 +139,6 @@ SCM_API SCM scm_procedure_with_setter_p (SCM obj); SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter); SCM_API SCM scm_procedure (SCM proc); SCM_API SCM scm_setter (SCM proc); -SCM_INTERNAL void scm_init_subr_table (void); SCM_INTERNAL void scm_init_procs (void); #ifdef GUILE_DEBUG From e092357058850a6f998bf462bdc5504c6379c96f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 11 Feb 2009 23:01:34 +0100 Subject: [PATCH 20/21] Small cleanup relative to the use of double cells for subrs. * libguile/procs.c (scm_c_make_subr): Remove comments about the number of subrs, improve formatting. --- libguile/procs.c | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/libguile/procs.c b/libguile/procs.c index e36e7ca16..af7f071f2 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -38,19 +38,13 @@ */ -/* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */ - -/* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on - startup, 786 with guile-readline. 'martin */ - SCM scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) { register SCM z; SCM *meta_info; - meta_info = scm_gc_malloc (2 * sizeof (* meta_info), - "subr meta-info"); + meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info"); meta_info[0] = scm_from_locale_symbol (name); meta_info[1] = SCM_EOL; /* properties */ From fe11efeebaa2ebb7bf0fe8bc46a29c152ead2509 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 12 Feb 2009 00:11:59 +0100 Subject: [PATCH 21/21] Update `NEWS'. --- NEWS | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 2d9916c5d..5e3f7ae4f 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,5 @@ Guile NEWS --- history of user-visible changes. -Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. @@ -40,6 +40,9 @@ application code. ** Functions for handling `scm_option' now no longer require an argument indicating length of the `scm_t_option' array. +** Primitive procedures (aka. "subrs") are now stored in double cells +This removes the subr table and simplifies the code. + Changes in 1.8.7 (since 1.8.6)