mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-22 19:44:10 +02:00
Code Activity

Merge branch 'boehm-demers-weiser-gc' into bdw-gc-static-alloc

Browse source
This commit is contained in:
Ludovic Courtès 2009-01-19 22:31:38 +01:00
commit 5bec288a67
61 changed files with 3565 additions and 6160 deletions
Download patch file Download diff file Expand all files Collapse all files

499
libguile/alloca.c
View file

@ -1,499 +0,0 @@
/* alloca.c -- allocate automatically reclaimed memory
(Mostly) portable public-domain implementation -- D A Gwyn
This implementation of the PWB library alloca function,
which is used to allocate space off the run-time stack so
that it is automatically reclaimed upon procedure exit,
was inspired by discussions with J. Q. Johnson of Cornell.
J.Otto Tennant <jot@cray.com> contributed the Cray support.
There are some preprocessor constants that can
be defined when compiling for your specific system, for
improved efficiency; however, the defaults should be okay.
The general concept of this implementation is to keep
track of all alloca-allocated blocks, and reclaim any
that are found to be deeper in the stack than the current
invocation. This heuristic does not reclaim storage as
soon as it becomes invalid, but it will do so eventually.
As a special case, alloca(0) reclaims storage without
allocating any. It is a good idea to use alloca(0) in
your main control loop, etc. to force garbage collection. */
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include "libguile/scmconfig.h"
#ifdef HAVE_STRING_H
#include <string.h>
#endif
#ifdef HAVE_STDLIB_H
#include <stdlib.h>
#endif
#ifdef emacs
#include "libguile/blockinput.h"
#endif
/* If compiling with GCC 2, this file's not needed. */
#if !defined (__GNUC__) || __GNUC__ < 2
/* If someone has defined alloca as a macro,
there must be some other way alloca is supposed to work. */
#ifndef alloca
#ifdef emacs
#ifdef static
/* actually, only want this if static is defined as ""
-- this is for usg, in which emacs must undefine static
in order to make unexec workable
*/
#ifndef STACK_DIRECTION
you
lose
-- must know STACK_DIRECTION at compile-time
#endif /* STACK_DIRECTION undefined */
#endif /* static */
#endif /* emacs */
/* If your stack is a linked list of frames, you have to
provide an "address metric" ADDRESS_FUNCTION macro. */
#if defined (CRAY) && defined (CRAY_STACKSEG_END)
long i00afunc ();
#define ADDRESS_FUNCTION(arg) (char *) i00afunc (&(arg))
#else
#define ADDRESS_FUNCTION(arg) &(arg)
#endif
#if __STDC__
typedef void *pointer;
#else
typedef char *pointer;
#endif
#ifndef NULL
#define NULL 0
#endif
/* Define STACK_DIRECTION if you know the direction of stack
growth for your system; otherwise it will be automatically
deduced at run-time.
STACK_DIRECTION > 0 => grows toward higher addresses
STACK_DIRECTION < 0 => grows toward lower addresses
STACK_DIRECTION = 0 => direction of growth unknown */
#ifndef STACK_DIRECTION
#define STACK_DIRECTION 0 /* Direction unknown. */
#endif
#if STACK_DIRECTION != 0
#define STACK_DIR STACK_DIRECTION /* Known at compile-time. */
#else /* STACK_DIRECTION == 0; need run-time code. */
static int stack_dir; /* 1 or -1 once known. */
#define STACK_DIR stack_dir
static void
find_stack_direction ()
{
static char *addr = NULL; /* Address of first `dummy', once known. */
auto char dummy; /* To get stack address. */
if (addr == NULL)
{ /* Initial entry. */
addr = ADDRESS_FUNCTION (dummy);
find_stack_direction (); /* Recurse once. */
}
else
{
/* Second entry. */
if (ADDRESS_FUNCTION (dummy) > addr)
stack_dir = 1; /* Stack grew upward. */
else
stack_dir = -1; /* Stack grew downward. */
}
}
#endif /* STACK_DIRECTION == 0 */
/* An "alloca header" is used to:
(a) chain together all alloca'ed blocks;
(b) keep track of stack depth.
It is very important that sizeof(header) agree with malloc
alignment chunk size. The following default should work okay. */
#ifndef ALIGN_SIZE
#define ALIGN_SIZE sizeof(double)
#endif
typedef union hdr
{
char align[ALIGN_SIZE]; /* To force sizeof(header). */
struct
{
union hdr *next; /* For chaining headers. */
char *deep; /* For stack depth measure. */
} h;
} header;
static header *last_alloca_header = NULL; /* -> last alloca header. */
/* Return a pointer to at least SIZE bytes of storage,
which will be automatically reclaimed upon exit from
the procedure that called alloca. Originally, this space
was supposed to be taken from the current stack frame of the
caller, but that method cannot be made to work for some
implementations of C, for example under Gould's UTX/32. */
pointer
alloca (unsigned size)
{
auto char probe; /* Probes stack depth: */
register char *depth = ADDRESS_FUNCTION (probe);
#if STACK_DIRECTION == 0
if (STACK_DIR == 0) /* Unknown growth direction. */
find_stack_direction ();
#endif
/* Reclaim garbage, defined as all alloca'd storage that
was allocated from deeper in the stack than currently. */
{
register header *hp; /* Traverses linked list. */
#ifdef emacs
BLOCK_INPUT;
#endif
for (hp = last_alloca_header; hp != NULL;)
if ((STACK_DIR > 0 && hp->h.deep > depth)
|| (STACK_DIR < 0 && hp->h.deep < depth))
{
register header *np = hp->h.next;
free ((pointer) hp); /* Collect garbage. */
hp = np; /* -> next header. */
}
else
break; /* Rest are not deeper. */
last_alloca_header = hp; /* -> last valid storage. */
#ifdef emacs
UNBLOCK_INPUT;
#endif
}
if (size == 0)
return NULL; /* No allocation required. */
/* Allocate combined header + user data storage. */
{
register pointer new = (pointer) scm_malloc (sizeof (header) + size);
/* Address of header. */
if (new == 0)
{
write (2, "alloca emulation: out of memory\n", 32);
abort();
}
((header *) new)->h.next = last_alloca_header;
((header *) new)->h.deep = depth;
last_alloca_header = (header *) new;
/* User storage begins just after header. */
return (pointer) ((char *) new + sizeof (header));
}
}
#if defined (CRAY) && defined (CRAY_STACKSEG_END)
#ifdef DEBUG_I00AFUNC
#include <stdio.h>
#endif
#ifndef CRAY_STACK
#define CRAY_STACK
#ifndef CRAY2
/* Stack structures for CRAY-1, CRAY X-MP, and CRAY Y-MP */
struct stack_control_header
{
long shgrow:32; /* Number of times stack has grown. */
long shaseg:32; /* Size of increments to stack. */
long shhwm:32; /* High water mark of stack. */
long shsize:32; /* Current size of stack (all segments). */
};
/* The stack segment linkage control information occurs at
the high-address end of a stack segment. (The stack
grows from low addresses to high addresses.) The initial
part of the stack segment linkage control information is
0200 (octal) words. This provides for register storage
for the routine which overflows the stack. */
struct stack_segment_linkage
{
long ss[0200]; /* 0200 overflow words. */
long sssize:32; /* Number of words in this segment. */
long ssbase:32; /* Offset to stack base. */
long:32;
long sspseg:32; /* Offset to linkage control of previous
segment of stack. */
long:32;
long sstcpt:32; /* Pointer to task common address block. */
long sscsnm; /* Private control structure number for
microtasking. */
long ssusr1; /* Reserved for user. */
long ssusr2; /* Reserved for user. */
long sstpid; /* Process ID for pid based multi-tasking. */
long ssgvup; /* Pointer to multitasking thread giveup. */
long sscray[7]; /* Reserved for Cray Research. */
long ssa0;
long ssa1;
long ssa2;
long ssa3;
long ssa4;
long ssa5;
long ssa6;
long ssa7;
long sss0;
long sss1;
long sss2;
long sss3;
long sss4;
long sss5;
long sss6;
long sss7;
};
#else /* CRAY2 */
/* The following structure defines the vector of words
returned by the STKSTAT library routine. */
struct stk_stat
{
long now; /* Current total stack size. */
long maxc; /* Amount of contiguous space which would
be required to satisfy the maximum
stack demand to date. */
long high_water; /* Stack high-water mark. */
long overflows; /* Number of stack overflow ($STKOFEN) calls. */
long hits; /* Number of internal buffer hits. */
long extends; /* Number of block extensions. */
long stko_mallocs; /* Block allocations by $STKOFEN. */
long underflows; /* Number of stack underflow calls ($STKRETN). */
long stko_free; /* Number of deallocations by $STKRETN. */
long stkm_free; /* Number of deallocations by $STKMRET. */
long segments; /* Current number of stack segments. */
long maxs; /* Maximum number of stack segments so far. */
long pad_size; /* Stack pad size. */
long current_address; /* Current stack segment address. */
long current_size; /* Current stack segment size. This
number is actually corrupted by STKSTAT to
include the fifteen word trailer area. */
long initial_address; /* Address of initial segment. */
long initial_size; /* Size of initial segment. */
};
/* The following structure describes the data structure which trails
any stack segment. I think that the description in 'asdef' is
out of date. I only describe the parts that I am sure about. */
struct stk_trailer
{
long this_address; /* Address of this block. */
long this_size; /* Size of this block (does not include
this trailer). */
long unknown2;
long unknown3;
long link; /* Address of trailer block of previous
segment. */
long unknown5;
long unknown6;
long unknown7;
long unknown8;
long unknown9;
long unknown10;
long unknown11;
long unknown12;
long unknown13;
long unknown14;
};
#endif /* CRAY2 */
#endif /* not CRAY_STACK */
#ifdef CRAY2
/* Determine a "stack measure" for an arbitrary ADDRESS.
I doubt that "lint" will like this much. */
static long
i00afunc (long *address)
{
struct stk_stat status;
struct stk_trailer *trailer;
long *block, size;
long result = 0;
/* We want to iterate through all of the segments. The first
step is to get the stack status structure. We could do this
more quickly and more directly, perhaps, by referencing the
$LM00 common block, but I know that this works. */
STKSTAT (&status);
/* Set up the iteration. */
trailer = (struct stk_trailer *) (status.current_address
+ status.current_size
- 15);
/* There must be at least one stack segment. Therefore it is
a fatal error if "trailer" is null. */
if (trailer == 0)
abort ();
/* Discard segments that do not contain our argument address. */
while (trailer != 0)
{
block = (long *) trailer->this_address;
size = trailer->this_size;
if (block == 0 || size == 0)
abort ();
trailer = (struct stk_trailer *) trailer->link;
if ((block <= address) && (address < (block + size)))
break;
}
/* Set the result to the offset in this segment and add the sizes
of all predecessor segments. */
result = address - block;
if (trailer == 0)
{
return result;
}
do
{
if (trailer->this_size <= 0)
abort ();
result += trailer->this_size;
trailer = (struct stk_trailer *) trailer->link;
}
while (trailer != 0);
/* We are done. Note that if you present a bogus address (one
not in any segment), you will get a different number back, formed
from subtracting the address of the first block. This is probably
not what you want. */
return (result);
}
#else /* not CRAY2 */
/* Stack address function for a CRAY-1, CRAY X-MP, or CRAY Y-MP.
Determine the number of the cell within the stack,
given the address of the cell. The purpose of this
routine is to linearize, in some sense, stack addresses
for alloca. */
static long
i00afunc (long address)
{
long stkl = 0;
long size, pseg, this_segment, stack;
long result = 0;
struct stack_segment_linkage *ssptr;
/* Register B67 contains the address of the end of the
current stack segment. If you (as a subprogram) store
your registers on the stack and find that you are past
the contents of B67, you have overflowed the segment.
B67 also points to the stack segment linkage control
area, which is what we are really interested in. */
stkl = CRAY_STACKSEG_END ();
ssptr = (struct stack_segment_linkage *) stkl;
/* If one subtracts 'size' from the end of the segment,
one has the address of the first word of the segment.
If this is not the first segment, 'pseg' will be
nonzero. */
pseg = ssptr->sspseg;
size = ssptr->sssize;
this_segment = stkl - size;
/* It is possible that calling this routine itself caused
a stack overflow. Discard stack segments which do not
contain the target address. */
while (!(this_segment <= address && address <= stkl))
{
#ifdef DEBUG_I00AFUNC
fprintf (stderr, "%011o %011o %011o\n", this_segment, address, stkl);
#endif
if (pseg == 0)
break;
stkl = stkl - pseg;
ssptr = (struct stack_segment_linkage *) stkl;
size = ssptr->sssize;
pseg = ssptr->sspseg;
this_segment = stkl - size;
}
result = address - this_segment;
/* If you subtract pseg from the current end of the stack,
you get the address of the previous stack segment's end.
This seems a little convoluted to me, but I'll bet you save
a cycle somewhere. */
while (pseg != 0)
{
#ifdef DEBUG_I00AFUNC
fprintf (stderr, "%011o %011o\n", pseg, size);
#endif
stkl = stkl - pseg;
ssptr = (struct stack_segment_linkage *) stkl;
size = ssptr->sssize;
pseg = ssptr->sspseg;
result += size;
}
return (result);
}
#endif /* not CRAY2 */
#endif /* CRAY */
#endif /* no alloca */
#endif /* not GCC version 2 */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

943
libguile/coop-pthreads.c
View file

@ -1,943 +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 <unistd.h>
#include <stdio.h>
#include <assert.h>
#include <sys/time.h>
#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/smob.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");
SCM_NEWSMOB (z, 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 int
thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
scm_copt_thread *t = SCM_THREAD_DATA (exp);
scm_puts ("#<thread ", port);
scm_uintprint ((scm_t_bits)t, 16, port);
if (t->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_gc_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;
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_print (scm_tc16_thread, thread_print);
}
/*** 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
/*** 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:
*/

83
libguile/coop-pthreads.h
View file

@ -1,83 +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 <pthread.h>
#include "libguile/boehm-gc.h"
#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:
*/

763
libguile/coop.c
View file

@ -1,763 +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 <config.h>
#endif
#include <stdio.h>
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#include <errno.h>
#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
#include "libguile/boehm-gc.h"
/* 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:
*/

2
libguile/debug-malloc.c
View file

@ -220,7 +220,7 @@ SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0,
int i;
for (i = 0; i < malloc_type_size + N_SEEK; ++i)
if (malloc_type[i].key)
res = scm_acons (scm_makfrom0str ((char *) malloc_type[i].key),
res = scm_acons (scm_from_locale_string ((char *) malloc_type[i].key),
scm_from_int ((int) malloc_type[i].data),
res);
return res;

13
libguile/dynl.c
View file

@ -1,7 +1,7 @@
/* dynl.c - dynamic linking
*
* Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002,
* 2003, 2008 Free Software Foundation, Inc.
* 2003, 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
@ -262,12 +262,6 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
}
#undef FUNC_NAME
static void
free_string_pointers (void *data)
{
scm_i_free_string_pointers ((char **)data);
}
SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
(SCM func, SCM dobj, SCM args),
"Call the C function indicated by @var{func} and @var{dobj},\n"
@ -288,21 +282,16 @@ SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
int result, argc;
char **argv;
scm_dynwind_begin (0);
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
fptr = (int (*) (int, char **)) scm_to_ulong (func);
argv = scm_i_allocate_string_pointers (args);
scm_dynwind_unwind_handler (free_string_pointers, argv,
SCM_F_WIND_EXPLICITLY);
for (argc = 0; argv[argc]; argc++)
;
result = (*fptr) (argc, argv);
scm_dynwind_end ();
return scm_from_int (result);
}
#undef FUNC_NAME

11
libguile/fluids.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1996,1997,2000,2001, 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
@ -152,9 +152,9 @@ next_fluid_num ()
/* FIXME: Since we use `scm_malloc ()', ALLOCATED_FLUIDS is scanned by
the GC; therefore, all fluids remain reachable for the entire
program lifetime. Hopefully this is not a problem in practice. */
char *prev_allocated_fluids;
char *new_allocated_fluids =
scm_malloc (allocated_fluids_len + FLUID_GROW);
scm_gc_malloc (allocated_fluids_len + FLUID_GROW,
"allocated fluids");
/* Copy over old values and initialize rest. GC can not run
during these two operations since there is no safe point in
@ -164,16 +164,11 @@ next_fluid_num ()
memset (new_allocated_fluids + allocated_fluids_len, 0, FLUID_GROW);
n = allocated_fluids_len;
prev_allocated_fluids = allocated_fluids;
/* Update the vector of allocated fluids. Dynamic states will
eventually be lazily grown to accomodate the new value of
ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */
allocated_fluids = new_allocated_fluids;
allocated_fluids_len += FLUID_GROW;
if (prev_allocated_fluids != NULL)
free (prev_allocated_fluids);
}
allocated_fluids_num += 1;

37
libguile/goops.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008
/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@ -152,8 +152,13 @@ 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;
SCM *scm_smob_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;
@ -1216,7 +1221,10 @@ SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0,
unsigned long int i;
SCM_VALIDATE_INSTANCE (1, obj);
i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1);
i = scm_to_unsigned_integer (index, 0,
SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
scm_si_nfields))
- 1);
return SCM_SLOT (obj, i);
}
#undef FUNC_NAME
@ -1230,7 +1238,10 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0,
unsigned long int i;
SCM_VALIDATE_INSTANCE (1, obj);
i = scm_to_unsigned_integer (index, 0, SCM_NUMBER_OF_SLOTS(obj)-1);
i = scm_to_unsigned_integer (index, 0,
SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
scm_si_nfields))
- 1);
SCM_SET_SLOT (obj, i, value);
@ -1873,6 +1884,11 @@ typedef struct t_extension {
SCM extension;
} t_extension;
/* Hint for `scm_gc_malloc ()' et al. when allocating `t_extension'
objects. */
static const char extension_gc_hint[] = "GOOPS extension";
static t_extension *extensions = 0;
SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
@ -1893,7 +1909,8 @@ scm_c_extend_primitive_generic (SCM extended, SCM extension)
}
else
{
t_extension *e = scm_malloc (sizeof (t_extension));
t_extension *e = scm_gc_malloc (sizeof (t_extension),
extension_gc_hint);
t_extension **loc = &extensions;
/* Make sure that extensions are placed before their own
* extensions in the extensions list. O(N^2) algorithm, but
@ -1916,7 +1933,6 @@ setup_extended_primitive_generics ()
t_extension *e = extensions;
scm_c_extend_primitive_generic (e->extended, e->extension);
extensions = e->next;
free (e);
}
}
@ -2686,8 +2702,7 @@ create_smob_classes (void)
{
long i;
scm_smob_class = (SCM *) scm_malloc (255 * sizeof (SCM));
for (i = 0; i < 255; ++i)
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;
@ -2731,10 +2746,6 @@ 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;
for (i = 0; i < scm_numptob; ++i)
scm_make_port_classes (i, SCM_PTOBNAME (i));
}

8
libguile/goops.h
View file

@ -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
@ -98,8 +98,6 @@ typedef struct scm_t_method {
/* Also defined in libguile/objects.c */
#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
#define SCM_ACCESSORS_OF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x)[scm_si_getters_n_setters]))
#define SCM_NUMBER_OF_SLOTS(x) \
((SCM_STRUCT_DATA (x)[scm_struct_i_n_words]) - scm_struct_n_extra_words)
#define SCM_CLASSP(x) \
(SCM_STRUCTP (x) && SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_METACLASS)
@ -170,8 +168,8 @@ 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_smob_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;
SCM_API SCM scm_class_class;

11
libguile/hooks.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,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
@ -42,6 +42,9 @@
* using C level hooks.
*/
/* Hint for `scm_gc_malloc ()' and friends. */
static const char hook_entry_gc_hint[] = "hook entry";
void
scm_c_hook_init (scm_t_c_hook *hook, void *hook_data, scm_t_c_hook_type type)
{
@ -56,8 +59,10 @@ scm_c_hook_add (scm_t_c_hook *hook,
void *fn_data,
int appendp)
{
scm_t_c_hook_entry *entry = scm_malloc (sizeof (scm_t_c_hook_entry));
scm_t_c_hook_entry *entry;
scm_t_c_hook_entry **loc = &hook->first;
entry = scm_gc_malloc (sizeof (scm_t_c_hook_entry), hook_entry_gc_hint);
if (appendp)
while (*loc)
loc = &(*loc)->next;
@ -77,9 +82,7 @@ scm_c_hook_remove (scm_t_c_hook *hook,
{
if ((*loc)->func == func && (*loc)->data == fn_data)
{
scm_t_c_hook_entry *entry = *loc;
*loc = (*loc)->next;
free (entry);
return;
}
loc = &(*loc)->next;

8
libguile/objects.h
View file

@ -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;

6
libguile/ports.c
View file

@ -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
@ -134,7 +134,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;
tmp = (char *) scm_gc_realloc ((char *) scm_ptobs,
@ -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;
}

5
libguile/ports.h
View file

@ -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. */

31
libguile/posix.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 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
@ -943,12 +943,6 @@ SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_TCSETPGRP */
static void
free_string_pointers (void *data)
{
scm_i_free_string_pointers ((char **)data);
}
SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
(SCM filename, SCM args),
"Executes the file named by @var{path} as a new process image.\n"
@ -971,8 +965,6 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
scm_dynwind_free (exec_file);
exec_argv = scm_i_allocate_string_pointers (args);
scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
SCM_F_WIND_EXPLICITLY);
execv (exec_file,
#ifdef __MINGW32__
@ -1007,8 +999,6 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1,
scm_dynwind_free (exec_file);
exec_argv = scm_i_allocate_string_pointers (args);
scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
SCM_F_WIND_EXPLICITLY);
execvp (exec_file,
#ifdef __MINGW32__
@ -1047,12 +1037,7 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
scm_dynwind_free (exec_file);
exec_argv = scm_i_allocate_string_pointers (args);
scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
SCM_F_WIND_EXPLICITLY);
exec_env = scm_i_allocate_string_pointers (env);
scm_dynwind_unwind_handler (free_string_pointers, exec_env,
SCM_F_WIND_EXPLICITLY);
execve (exec_file,
#ifdef __MINGW32__
@ -1136,19 +1121,7 @@ SCM_DEFINE (scm_environ, "environ", 0, 1, 0,
return scm_makfromstrs (-1, environ);
else
{
char **new_environ;
new_environ = scm_i_allocate_string_pointers (env);
/* Free the old environment, except when called for the first
* time.
*/
{
static int first = 1;
if (!first)
scm_i_free_string_pointers (environ);
first = 0;
}
environ = new_environ;
environ = scm_i_allocate_string_pointers (env);
return SCM_UNSPECIFIED;
}
}

22
libguile/procs.c
View file

@ -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
@ -44,27 +44,32 @@ 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;
/* Hint for `scm_gc_malloc ()' and friends. */
static const char subr_table_gc_hint[] = "subr table";
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)
{
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_gc_realloc (scm_subr_table,
sizeof (* scm_subr_table) * scm_subr_table_room,
sizeof (* scm_subr_table) * new_size,
subr_table_gc_hint);
scm_subr_table = new_table;
scm_subr_table_room = new_size;
}
entry = scm_subr_table_size;
z = scm_immutable_cell ((entry << 8) + type, (scm_t_bits) fcn);
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;
@ -328,7 +333,8 @@ scm_init_subr_table ()
{
scm_subr_table
= ((scm_t_subr_entry *)
scm_malloc (sizeof (scm_t_subr_entry) * scm_subr_table_room));
scm_gc_malloc (sizeof (* scm_subr_table) * scm_subr_table_room,
subr_table_gc_hint));
}
void

4
libguile/procs.h
View file

@ -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
@ -125,8 +125,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;

13
libguile/simpos.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004 Free Software
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2009 Free Software
* Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@ -88,11 +88,6 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0,
#ifdef HAVE_SYSTEM
#ifdef HAVE_WAITPID
static void
free_string_pointers (void *data)
{
scm_i_free_string_pointers ((char **)data);
}
SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
(SCM args),
@ -127,12 +122,8 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
int pid;
char **execargv;
scm_dynwind_begin (0);
/* allocate before fork */
execargv = scm_i_allocate_string_pointers (args);
scm_dynwind_unwind_handler (free_string_pointers, execargv,
SCM_F_WIND_EXPLICITLY);
/* make sure the child can't kill us (as per normal system call) */
sig_ign = scm_from_long ((unsigned long) SIG_IGN);
@ -148,7 +139,6 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
execvp (execargv[0], execargv);
SCM_SYSERROR;
/* not reached. */
scm_dynwind_end ();
return SCM_BOOL_F;
}
else
@ -165,7 +155,6 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint));
scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit));
scm_dynwind_end ();
return scm_from_int (status);
}
}

11
libguile/smob.c
View file

@ -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
@ -49,7 +49,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];
@ -312,7 +313,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;
@ -452,8 +453,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)]);
}

5
libguile/smob.h
View file

@ -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
@ -152,6 +152,9 @@ while (0)
#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[];

31
libguile/strings.c
View file

@ -30,7 +30,6 @@
#include "libguile/strings.h"
#include "libguile/deprecation.h"
#include "libguile/validate.h"
#include "libguile/dynwind.h"
@ -949,6 +948,7 @@ scm_makfromstrs (int argc, char **argv)
char **
scm_i_allocate_string_pointers (SCM list)
#define FUNC_NAME "scm_i_allocate_string_pointers"
{
char **result;
int len = scm_ilength (list);
@ -957,34 +957,31 @@ scm_i_allocate_string_pointers (SCM list)
if (len < 0)
scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
scm_dynwind_begin (0);
result = (char **) scm_malloc ((len + 1) * sizeof (char *));
result = scm_gc_malloc ((len + 1) * sizeof (char *),
"string pointers");
result[len] = NULL;
scm_dynwind_unwind_handler (free, result, 0);
/* The list might be have been modified in another thread, so
we check LIST before each access.
*/
for (i = 0; i < len && scm_is_pair (list); i++)
{
result[i] = scm_to_locale_string (SCM_CAR (list));
SCM str;
size_t len;
str = SCM_CAR (list);
len = scm_c_string_length (str);
result[i] = scm_gc_malloc_pointerless (len + 1, "string pointers");
memcpy (result[i], scm_i_string_chars (str), len);
result[i][len] = '\0';
list = SCM_CDR (list);
}
scm_dynwind_end ();
return result;
}
void
scm_i_free_string_pointers (char **pointers)
{
int i;
for (i = 0; pointers[i]; i++)
free (pointers[i]);
free (pointers);
}
#undef FUNC_NAME
void
scm_i_get_substring_spec (size_t len,

1
libguile/strings.h
View file

@ -149,7 +149,6 @@ SCM_INTERNAL SCM scm_i_symbol_substring (SCM sym, size_t start, size_t end);
/* internal utility functions. */
SCM_INTERNAL char **scm_i_allocate_string_pointers (SCM list);
SCM_INTERNAL void scm_i_free_string_pointers (char **pointers);
SCM_INTERNAL void scm_i_get_substring_spec (size_t len,
SCM start, size_t *cstart,
SCM end, size_t *cend);