suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

revised Mac OS X sleeping; optional atomic mode for FFI callbacks

Browse Source 
svn: r13016
This commit is contained in:
Matthew Flatt 2009-01-06 13:07:45 +00:00
parent f5c77109fa
commit 61685c72f9
19 changed files with 213 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/mzlib/foreign.ss
View File

@ -468,17 +468,20 @@
;; optionally applying a wrapper function to modify the result primitive
;; (callouts) or the input procedure (callbacks).
(define* (_cprocedure itypes otype
#:abi [abi #f] #:wrapper [wrapper #f] #:keep [keep #f])
(_cprocedure* itypes otype abi wrapper keep))
#:abi [abi #f]
#:wrapper [wrapper #f]
#:keep [keep #f]
#:atomic? [atomic? #f])
(_cprocedure* itypes otype abi wrapper keep atomic?))
;; for internal use
(define held-callbacks (make-weak-hasheq))
(define (_cprocedure* itypes otype abi wrapper keep)
(define (_cprocedure* itypes otype abi wrapper keep atomic?)
(define-syntax-rule (make-it wrap)
(make-ctype _fpointer
(lambda (x)
(and x
(let ([cb (ffi-callback (wrap x) itypes otype abi)])
(let ([cb (ffi-callback (wrap x) itypes otype abi atomic?)])
(cond [(eq? keep #t) (hash-set! held-callbacks x cb)]
[(box? keep)
(let ([x (unbox keep)])
@ -514,6 +517,7 @@
(define xs #f)
(define abi #f)
(define keep #f)
(define atomic? #f)
(define inputs #f)
(define output #f)
(define bind '())
@ -578,9 +582,10 @@
(begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))]
...
[else (err "unknown keyword" (car xs))]))
(when (keyword? k) (kwds [#:abi abi] [#:keep keep]))))
(when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?]))))
(unless abi (set! abi #'#f))
(unless keep (set! keep #'#t))
(unless atomic? (set! atomic? #'#f))
;; parse known punctuation
(set! xs (map (lambda (x)
(syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x]))
@ -671,9 +676,9 @@
(string->symbol (string-append "ffi-wrapper:" n)))
body))])
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
#,abi (lambda (ffi) #,body) #,keep))
#,abi (lambda (ffi) #,body) #,keep #,atomic?))
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
#,abi #f #,keep)))
#,abi #f #,keep #,atomic?)))
(syntax-case stx ()
[(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))

14
collects/scribblings/foreign/types.scrbl
View File

@ -297,6 +297,7 @@ and normally @scheme[_cprocedure] should be used instead of
@defproc[(_cprocedure [input-types (list ctype?)]
[output-type ctype?]
[#:abi abi (or/c symbol/c #f) #f]
[#:atomic? atomic? any/c #f]
[#:wrapper wrapper (or/c #f (procedure? . -> . procedure?))
#f]
[#:keep keep (or/c boolean? box? (any/c . -> . any/c))
@ -328,6 +329,16 @@ platform-dependent default; other possible values are
``cdecl''). This is especially important on Windows, where most
system functions are @scheme['stdcall], which is not the default.
If @scheme[atomic?] is true, then when a Scheme procedure is given
this procedure type and called from foreign code, then the PLT Scheme
virtual machine is put into atomic mode while evaluating the Scheme
procedure body. In atomic mode, other Scheme threads cannot run, so
the Scheme code must not call any function that potentially
synchronizes with other threads (including I/O functions). In
addition, the Scheme code must not raise an uncaught exception, it
must not perform any escaping continuation jumps, and its non-tail
recursion must be minimal to avoid C-level stack overflow.
The optional @scheme[wrapper], if provided, is expected to be a
function that can change a callout procedure: when a callout is
generated, the wrapper is applied on the newly created primitive
@ -394,7 +405,8 @@ values: @itemize[
(_fun fun-option ... maybe-args type-spec ... -> type-spec
maybe-wrapper)
([fun-option (code:line #:abi abi-expr)
(code:line #:keep keep-expr)]
(code:line #:keep keep-expr)
(code:line #:atomic? atomic?-expr)]
[maybe-args code:blank
(code:line (id ...) ::)
(code:line id ::)

3
collects/scribblings/foreign/unexported.scrbl
View File

@ -62,7 +62,8 @@ especially important on Windows, where most system functions are
@defproc[(ffi-callback [proc any/c] [in-types any/c] [out-type any/c]
[abi (or/c symbol/c #f) #f])
[abi (or/c symbol/c #f) #f]
[atomic? any/c #f])
ffi-callback?]{
The symmetric counterpart of @scheme[ffi-call]. It receives a Scheme

8
src/foreign/foreign.c
View File

@ -1108,6 +1108,7 @@ typedef struct ffi_callback_struct {
Scheme_Object* proc;
Scheme_Object* itypes;
Scheme_Object* otype;
int call_in_scheduler;
} ffi_callback_struct;
#define SCHEME_FFICALLBACKP(x) (SCHEME_TYPE(x)==ffi_callback_tag)
#undef MYNAME
@ -2580,12 +2581,16 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
argv = argv_stack;
else
argv = scheme_malloc(argc * sizeof(Scheme_Object*));
if (data->call_in_scheduler)
scheme_start_in_scheduler();
for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
argv[i] = v;
}
p = _scheme_apply(data->proc, argc, argv);
SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
if (data->call_in_scheduler)
scheme_end_in_scheduler();
}
/* see ffi-callback below */
@ -2688,6 +2693,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
data->proc = (argv[0]);
data->itypes = (argv[1]);
data->otype = (argv[2]);
data->call_in_scheduler = (((argc > 4) && SCHEME_TRUEP(argv[4])));
#ifdef MZ_PRECISE_GC
{
/* put data in immobile, weak box */
@ -2853,7 +2859,7 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global("ffi-call",
scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv);
scheme_add_global("ffi-callback",
scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 4), menv);
scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 5), menv);
s = scheme_intern_symbol("void");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;

12
src/foreign/foreign.ssc
View File

@ -944,7 +944,8 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
(callback "void*")
(proc "Scheme_Object*")
(itypes "Scheme_Object*")
(otype "Scheme_Object*")):}
(otype "Scheme_Object*")
(call_in_scheduler "int")):}
/*****************************************************************************/
/* Pointer objects */
@ -1969,12 +1970,16 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
argv = argv_stack;
else
argv = scheme_malloc(argc * sizeof(Scheme_Object*));
if (data->call_in_scheduler)
scheme_start_in_scheduler();
for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
argv[i] = v;
}
p = _scheme_apply(data->proc, argc, argv);
SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
if (data->call_in_scheduler)
scheme_end_in_scheduler();
}
/* see ffi-callback below */
@ -2005,7 +2010,7 @@ void free_cl_cif_args(void *ignored, void *p)
/* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */
/* the treatment of in-types and out-types is similar to that in ffi-call */
/* the real work is done by ffi_do_callback above */
{:(cdefine ffi-callback 3 4):}
{:(cdefine ffi-callback 3 5):}
{
ffi_callback_struct *data;
Scheme_Object *itypes = argv[1];
@ -2070,7 +2075,8 @@ void free_cl_cif_args(void *ignored, void *p)
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
{:(cmake-object "data" ffi-callback
"cl_cif_args" "argv[0]" "argv[1]" "argv[2]"):}
"cl_cif_args" "argv[0]" "argv[1]" "argv[2]"
"((argc > 4) && SCHEME_TRUEP(argv[4]))"):}
#ifdef MZ_PRECISE_GC
{
/* put data in immobile, weak box */

96
src/mred/mredmac.cxx
View File

@ -1179,103 +1179,20 @@ int MrEdCheckForBreak(void)
/***************************************************************************/
#include <pthread.h>
static volatile int thread_running;
static volatile int need_post; /* 0=>1 transition has a benign race condition, an optimization */
static SLEEP_PROC_PTR mzsleep;
static pthread_t watcher;
static volatile float sleep_secs;
/* These file descriptors act as semaphores: */
static int watch_read_fd, watch_write_fd;
static int watch_done_read_fd, watch_done_write_fd;
/* These file descriptors are used for breaking the event loop.
See ARGH below. */
/* These file descriptors are used for breaking the event loop. */
static int cb_socket_ready;
static int ready_sock, write_ready_sock;
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
#endif
static void *do_watch(void *fds)
{
while (1) {
char buf[1];
read(watch_read_fd, buf, 1);
mzsleep(sleep_secs, fds);
if (need_post) {
need_post = 0;
if (cb_socket_ready) {
/* Sometimes WakeUpProcess() doesn't work.
Try a notification socket as a backup.
See ARGH below. */
write(write_ready_sock, "y", 1);
}
}
write(watch_done_write_fd, "y", 1);
}
return NULL;
}
#ifdef MZ_PRECISE_GC
END_XFORM_SKIP;
#endif
static int StartFDWatcher(void (*mzs)(float secs, void *fds), float secs, void *fds)
{
if (!watch_write_fd) {
int fds[2];
if (!pipe(fds)) {
watch_read_fd = fds[0];
watch_write_fd = fds[1];
} else {
return 0;
}
}
if (!watch_done_write_fd) {
int fds[2];
if (!pipe(fds)) {
watch_done_read_fd = fds[0];
watch_done_write_fd = fds[1];
} else {
return 0;
}
}
if (!watcher) {
if (pthread_create(&watcher, NULL, do_watch, fds)) {
return 0;
}
}
mzsleep = mzs;
sleep_secs = secs;
thread_running = 1;
need_post = 1;
write(watch_write_fd, "x", 1);
scheme_start_sleeper_thread(mzs, secs, fds, write_ready_sock);
return 1;
}
static void EndFDWatcher(void)
{
char buf[1];
if (thread_running) {
if (need_post) {
need_post = 0;
scheme_signal_received();
}
read(watch_done_read_fd, buf, 1);
thread_running = 0;
}
scheme_end_sleeper_thread();
}
void socket_callback(CFSocketRef s, CFSocketCallBackType type, CFDataRef address, const void *data, void *info)
@ -1369,11 +1286,8 @@ void MrEdMacSleep(float secs, void *fds, SLEEP_PROC_PTR mzsleep)
going++;
if (need_post) /* useless check in principle, but an optimization
in the case that the select() succeeds before
we even start */
if (WNE(&e, secs ? secs : kEventDurationForever))
QueueTransferredEvent(&e);
if (WNE(&e, secs ? secs : kEventDurationForever))
QueueTransferredEvent(&e);
--going;

4
src/mzscheme/include/mzscheme.exp
View File

@ -23,6 +23,8 @@ scheme_get_current_thread
scheme_start_atomic
scheme_end_atomic
scheme_end_atomic_no_swap
scheme_start_in_scheduler
scheme_end_in_scheduler
scheme_out_of_fuel
scheme_thread
scheme_thread_w_details
@ -43,6 +45,8 @@ scheme_wait_input_allowed
scheme_unless_ready
scheme_in_main_thread
scheme_cancel_sleep
scheme_start_sleeper_thread
scheme_end_sleeper_thread
scheme_make_thread_cell
scheme_thread_cell_get
scheme_thread_cell_set

4
src/mzscheme/include/mzscheme3m.exp
View File

@ -23,6 +23,8 @@ scheme_get_current_thread
scheme_start_atomic
scheme_end_atomic
scheme_end_atomic_no_swap
scheme_start_in_scheduler
scheme_end_in_scheduler
scheme_out_of_fuel
scheme_thread
scheme_thread_w_details
@ -43,6 +45,8 @@ scheme_wait_input_allowed
scheme_unless_ready
scheme_in_main_thread
scheme_cancel_sleep
scheme_start_sleeper_thread
scheme_end_sleeper_thread
scheme_make_thread_cell
scheme_thread_cell_get
scheme_thread_cell_set

4
src/mzscheme/include/mzwin.def
View File

@ -25,6 +25,8 @@ EXPORTS
scheme_start_atomic
scheme_end_atomic
scheme_end_atomic_no_swap
scheme_start_in_scheduler
scheme_end_in_scheduler
scheme_out_of_fuel
scheme_thread
scheme_thread_w_details
@ -45,6 +47,8 @@ EXPORTS
scheme_unless_ready
scheme_in_main_thread
scheme_cancel_sleep
scheme_start_sleeper_thread
scheme_end_sleeper_thread
scheme_make_thread_cell
scheme_thread_cell_get
scheme_thread_cell_set

4
src/mzscheme/include/mzwin3m.def
View File

@ -25,6 +25,8 @@ EXPORTS
scheme_start_atomic
scheme_end_atomic
scheme_end_atomic_no_swap
scheme_start_in_scheduler
scheme_end_in_scheduler
scheme_out_of_fuel
scheme_thread
scheme_thread_w_details
@ -45,6 +47,8 @@ EXPORTS
scheme_unless_ready
scheme_in_main_thread
scheme_cancel_sleep
scheme_start_sleeper_thread
scheme_end_sleeper_thread
scheme_make_thread_cell
scheme_thread_cell_get
scheme_thread_cell_set

8
src/mzscheme/src/mzstkchk.h
View File

@ -9,10 +9,11 @@
unsigned long _stk_pos;
_stk_pos = (unsigned long)&_stk_pos;
if (STK_COMP(_stk_pos, (unsigned long)SCHEME_CURRENT_PROCESS->stack_end))
if (STK_COMP(_stk_pos, (unsigned long)SCHEME_CURRENT_PROCESS->stack_end)
&& !scheme_no_stack_overflow)
#else
# ifdef USE_STACKAVAIL
if (stackavail() < STACK_SAFETY_MARGIN)
if ((stackavail() < STACK_SAFETY_MARGIN) && !scheme_no_stack_overflow)
# endif
# if defined(UNIX_FIND_STACK_BOUNDS) || defined(WINDOWS_FIND_STACK_BOUNDS) \
|| defined(MACOS_FIND_STACK_BOUNDS) || defined(ASSUME_FIXED_STACK_SIZE) \
@ -22,7 +23,8 @@
_stk_pos = (unsigned long)&_stk_pos;
if (STK_COMP(_stk_pos, SCHEME_STACK_BOUNDARY))
if (STK_COMP(_stk_pos, SCHEME_STACK_BOUNDARY)
&& !scheme_no_stack_overflow)
# endif
#endif

105
src/mzscheme/src/port.c
View File

@ -8291,6 +8291,111 @@ void scheme_start_itimer_thread(long usec)
#endif
#ifdef OS_X
/* Sleep-in-thread support needed for GUIs Mac OS X.
To merge waiting on a CoreFoundation event with a select(), an embedding
application can attach a single socket to an event callback, and then
create a Mac thread to call the usual sleep and write to the socket when
data is available. */
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
#endif
typedef struct {
pthread_mutex_t lock;
pthread_cond_t cond;
int count;
} pt_sema_t;
void pt_sema_init(pt_sema_t *sem)
{
pthread_mutex_init(&sem->lock, NULL);
pthread_cond_init(&sem->cond, NULL);
sem->count = 0;
}
void pt_sema_wait(pt_sema_t *sem)
{
pthread_mutex_lock(&sem->lock);
while (sem->count <= 0)
pthread_cond_wait(&sem->cond, &sem->lock);
sem->count--;
pthread_mutex_unlock(&sem->lock);
}
void pt_sema_post(pt_sema_t *sem)
{
pthread_mutex_lock(&sem->lock);
sem->count++;
if (sem->count > 0)
pthread_cond_signal(&sem->cond);
pthread_mutex_unlock(&sem->lock);
}
static pthread_t watcher;
static pt_sema_t sleeping_sema, done_sema;
static float sleep_secs;
static int slept_fd;
static void *sleep_fds;
static void (*sleep_sleep)(float seconds, void *fds);
static void *do_watch()
{
while (1) {
pt_sema_wait(&sleeping_sema);
sleep_sleep(sleep_secs, sleep_fds);
write(slept_fd, "y", 1);
pt_sema_post(&done_sema);
}
}
void scheme_start_sleeper_thread(void (*given_sleep)(float seconds, void *fds), float secs, void *fds, int hit_fd)
{
if (!watcher) {
pt_sema_init(&sleeping_sema);
pt_sema_init(&done_sema);
if (pthread_create(&watcher, NULL, do_watch, NULL)) {
scheme_log_abort("pthread_create failed");
abort();
}
}
sleep_sleep = given_sleep;
sleep_fds = fds;
sleep_secs = secs;
slept_fd = hit_fd;
pt_sema_post(&sleeping_sema);
}
void scheme_end_sleeper_thread()
{
scheme_signal_received();
pt_sema_wait(&done_sema);
/* Clear external event flag */
if (external_event_fd) {
char buf[10];
read(external_event_fd, buf, 10);
}
}
#ifdef MZ_PRECISE_GC
END_XFORM_SKIP;
#endif
#else
void scheme_start_sleeper_thread(void *fds, int hit_fd);
void scheme_end_sleeper_thread();
#endif
/*========================================================================*/
/* memory debugging help */
/*========================================================================*/

5
src/mzscheme/src/schemef.h
View File

@ -82,6 +82,8 @@ MZ_EXTERN Scheme_Thread *scheme_get_current_thread();
MZ_EXTERN void scheme_start_atomic(void);
MZ_EXTERN void scheme_end_atomic(void);
MZ_EXTERN void scheme_end_atomic_no_swap(void);
MZ_EXTERN void scheme_start_in_scheduler(void);
MZ_EXTERN void scheme_end_in_scheduler(void);
MZ_EXTERN void scheme_out_of_fuel(void);
@ -120,6 +122,9 @@ MZ_EXTERN int scheme_in_main_thread(void);
MZ_EXTERN void scheme_cancel_sleep(void);
MZ_EXTERN void scheme_start_sleeper_thread(void (*mzsleep)(float seconds, void *fds), float secs, void *fds, int hit_fd);
MZ_EXTERN void scheme_end_sleeper_thread();
MZ_EXTERN Scheme_Object *scheme_make_thread_cell(Scheme_Object *def_val, int inherited);
MZ_EXTERN Scheme_Object *scheme_thread_cell_get(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells);
MZ_EXTERN void scheme_thread_cell_set(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells, Scheme_Object *v);

4
src/mzscheme/src/schemex.h
View File

@ -66,6 +66,8 @@ Scheme_Thread *(*scheme_get_current_thread)();
void (*scheme_start_atomic)(void);
void (*scheme_end_atomic)(void);
void (*scheme_end_atomic_no_swap)(void);
void (*scheme_start_in_scheduler)(void);
void (*scheme_end_in_scheduler)(void);
void (*scheme_out_of_fuel)(void);
Scheme_Object *(*scheme_thread)(Scheme_Object *thunk);
Scheme_Object *(*scheme_thread_w_details)(Scheme_Object *thunk,
@ -95,6 +97,8 @@ void (*scheme_wait_input_allowed)(Scheme_Input_Port *port, int nonblock);
int (*scheme_unless_ready)(Scheme_Object *unless);
int (*scheme_in_main_thread)(void);
void (*scheme_cancel_sleep)(void);
void (*scheme_start_sleeper_thread)(void (*mzsleep)(float seconds, void *fds), float secs, void *fds, int hit_fd);
void (*scheme_end_sleeper_thread)();
Scheme_Object *(*scheme_make_thread_cell)(Scheme_Object *def_val, int inherited);
Scheme_Object *(*scheme_thread_cell_get)(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells);
void (*scheme_thread_cell_set)(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells, Scheme_Object *v);

4
src/mzscheme/src/schemex.inc
View File

@ -31,6 +31,8 @@
scheme_extension_table->scheme_start_atomic = scheme_start_atomic;
scheme_extension_table->scheme_end_atomic = scheme_end_atomic;
scheme_extension_table->scheme_end_atomic_no_swap = scheme_end_atomic_no_swap;
scheme_extension_table->scheme_start_in_scheduler = scheme_start_in_scheduler;
scheme_extension_table->scheme_end_in_scheduler = scheme_end_in_scheduler;
scheme_extension_table->scheme_out_of_fuel = scheme_out_of_fuel;
scheme_extension_table->scheme_thread = scheme_thread;
scheme_extension_table->scheme_thread_w_details = scheme_thread_w_details;
@ -51,6 +53,8 @@
scheme_extension_table->scheme_unless_ready = scheme_unless_ready;
scheme_extension_table->scheme_in_main_thread = scheme_in_main_thread;
scheme_extension_table->scheme_cancel_sleep = scheme_cancel_sleep;
scheme_extension_table->scheme_start_sleeper_thread = scheme_start_sleeper_thread;
scheme_extension_table->scheme_end_sleeper_thread = scheme_end_sleeper_thread;
scheme_extension_table->scheme_make_thread_cell = scheme_make_thread_cell;
scheme_extension_table->scheme_thread_cell_get = scheme_thread_cell_get;
scheme_extension_table->scheme_thread_cell_set = scheme_thread_cell_set;

4
src/mzscheme/src/schemexm.h
View File

@ -31,6 +31,8 @@
#define scheme_start_atomic (scheme_extension_table->scheme_start_atomic)
#define scheme_end_atomic (scheme_extension_table->scheme_end_atomic)
#define scheme_end_atomic_no_swap (scheme_extension_table->scheme_end_atomic_no_swap)
#define scheme_start_in_scheduler (scheme_extension_table->scheme_start_in_scheduler)
#define scheme_end_in_scheduler (scheme_extension_table->scheme_end_in_scheduler)
#define scheme_out_of_fuel (scheme_extension_table->scheme_out_of_fuel)
#define scheme_thread (scheme_extension_table->scheme_thread)
#define scheme_thread_w_details (scheme_extension_table->scheme_thread_w_details)
@ -51,6 +53,8 @@
#define scheme_unless_ready (scheme_extension_table->scheme_unless_ready)
#define scheme_in_main_thread (scheme_extension_table->scheme_in_main_thread)
#define scheme_cancel_sleep (scheme_extension_table->scheme_cancel_sleep)
#define scheme_start_sleeper_thread (scheme_extension_table->scheme_start_sleeper_thread)
#define scheme_end_sleeper_thread (scheme_extension_table->scheme_end_sleeper_thread)
#define scheme_make_thread_cell (scheme_extension_table->scheme_make_thread_cell)
#define scheme_thread_cell_get (scheme_extension_table->scheme_thread_cell_get)
#define scheme_thread_cell_set (scheme_extension_table->scheme_thread_cell_set)

2
src/mzscheme/src/schpriv.h
View File

@ -362,6 +362,8 @@ extern mz_proc_thread *scheme_master_proc_thread;
extern THREAD_LOCAL mz_proc_thread *proc_thread_self;
#endif
extern int scheme_no_stack_overflow;
typedef struct Scheme_Thread_Set {
Scheme_Object so;
struct Scheme_Thread_Set *parent;

4
src/mzscheme/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.1.3.8"
#define MZSCHEME_VERSION "4.1.3.9"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 3
#define MZSCHEME_VERSION_W 8
#define MZSCHEME_VERSION_W 9
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

20
src/mzscheme/src/thread.c
View File

@ -220,6 +220,7 @@ static int missed_context_switch = 0;
static int have_activity = 0;
int scheme_active_but_sleeping = 0;
static int thread_ended_with_activity;
int scheme_no_stack_overflow;
static int needs_sleep_cancelled;
@ -3437,13 +3438,16 @@ static int check_sleep(int need_activity, int sleep_now)
{
Scheme_Thread *p, *p2;
int end_with_act;
#if defined(USING_FDS)
DECL_FDSET(set, 3);
fd_set *set1, *set2;
#endif
void *fds;
if (scheme_no_stack_overflow)
return 0;
/* Is everything blocked? */
if (!do_atomic) {
p = scheme_first_thread;
@ -3641,7 +3645,7 @@ static int can_break_param(Scheme_Thread *p)
int scheme_can_break(Scheme_Thread *p)
{
if (!p->suspend_break) {
if (!p->suspend_break && !scheme_no_stack_overflow) {
return can_break_param(p);
} else
return 0;
@ -4361,6 +4365,18 @@ void scheme_end_atomic_no_swap(void)
--do_atomic;
}
void scheme_start_in_scheduler(void)
{
do_atomic++;
scheme_no_stack_overflow++;
}
void scheme_end_in_scheduler(void)
{
--do_atomic;
--scheme_no_stack_overflow;
}
void scheme_end_atomic(void)
{
scheme_end_atomic_no_swap();