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

Merge remote-tracking branch 'origin/stable-2.0'

Browse source
This commit is contained in:
Andy Wingo 2011-05-26 18:30:37 +02:00
commit ee395b7cfb
2 changed files with 50 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

36
libguile/scmsigs.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008, 2009, 2011 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
@ -148,11 +148,28 @@ take_signal (int signum)
#endif
}
struct signal_pipe_data
{
char sigbyte;
ssize_t n;
int err;
};
static void*
read_signal_pipe_data (void * data)
{
struct signal_pipe_data *sdata = data;
sdata->n = read (signal_pipe[0], &sdata->sigbyte, 1);
sdata->err = errno;
return NULL;
}
static SCM
signal_delivery_thread (void *data)
{
int n, sig;
char sigbyte;
int sig;
#if HAVE_PTHREAD_SIGMASK /* not on mingw, see notes above */
sigset_t all_sigs;
sigfillset (&all_sigs);
@ -161,9 +178,12 @@ signal_delivery_thread (void *data)
while (1)
{
n = read (signal_pipe[0], &sigbyte, 1);
sig = sigbyte;
if (n == 1 && sig >= 0 && sig < NSIG)
struct signal_pipe_data sigdata;
scm_without_guile (read_signal_pipe_data, &sigdata);
sig = sigdata.sigbyte;
if (sigdata.n == 1 && sig >= 0 && sig < NSIG)
{
SCM h, t;
@ -172,9 +192,9 @@ signal_delivery_thread (void *data)
if (scm_is_true (h))
scm_system_async_mark_for_thread (h, t);
}
else if (n == 0)
else if (sigdata.n == 0)
break; /* the signal pipe was closed. */
else if (n < 0 && errno != EINTR)
else if (sigdata.n < 0 && sigdata.err != EINTR)
perror ("error in signal delivery thread");
}

35
module/ice-9/futures.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2010 Free Software Foundation, Inc.
;;; Copyright (C) 2010, 2011 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
@ -54,6 +54,7 @@
"Return a new future for THUNK. Execution may start at any point
concurrently, or it can start at the time when the returned future is
touched."
(create-workers!)
(let ((future (%make-future thunk #f (make-mutex))))
(register-future! future)
future))
@ -145,19 +146,27 @@ touched."
(- (current-processor-count) 1)
0))
(define %workers
;; A dock of workers that stay here forever.
;; A dock of workers that stay here forever.
;; TODO
;; 1. Allocate lazily.
;; 2. Allow the pool to be shrunk, as in libgomp (though that we'd
;; need semaphores, which aren't yet in libguile!).
;; 3. Provide a `worker-count' fluid.
(unfold (lambda (i) (>= i %worker-count))
(lambda (i)
(call-with-new-thread process-futures))
1+
0))
;; TODO
;; 1. Allow the pool to be shrunk, as in libgomp (though that we'd
;; need semaphores, which aren't yet in libguile!).
;; 2. Provide a `worker-count' fluid.
(define %workers '())
(define (%create-workers!)
(lock-mutex %futures-mutex)
(set! %workers
(unfold (lambda (i) (>= i %worker-count))
(lambda (i)
(call-with-new-thread process-futures))
1+
0))
(set! create-workers! (lambda () #t))
(unlock-mutex %futures-mutex))
(define create-workers!
(lambda () (%create-workers!)))
;;;