Commit af7f500b authored by Erick's avatar Erick

Regression fix: With R7RS current-time threads timeout may be rationals

parent 94c4cf00
/*
* mutex-common.c -- Common Mutexes in Scheme
* mutex-common.c -- Common Mutexes in Scheme
*
* Copyright © 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 2-Feb-2006 21:58 (eg)
* Last file update: 25-Oct-2006 16:22 (eg)
* Last file update: 21-Sep-2018 08:54 (eg)
*/
#include <unistd.h>
......@@ -32,7 +32,7 @@
/* ====================================================================== *\
*
* M U T E X E S
* M U T E X E S
*
\* ====================================================================== */
......@@ -48,11 +48,6 @@ void STk_error_deadlock(void)
STk_error("cannot lock mutex (deadlock will occur)");
}
void STk_error_bad_timeout(SCM tm)
{
STk_error("bad timeout ~S", tm);
}
/* ====================================================================== */
/*
......@@ -158,7 +153,7 @@ DEFINE_PRIMITIVE("mutex-specific-set!", mutex_specific_set, subr2, (SCM mtx, SCM
/* ====================================================================== *\
*
* C O N D V A R S
* C O N D V A R S
*
\* ====================================================================== */
......@@ -242,7 +237,7 @@ DEFINE_PRIMITIVE("condition-variable-specific", condv_specific, subr1, (SCM cv))
doc>
*/
DEFINE_PRIMITIVE("condition-variable-specific-set!", condv_specific_set, subr2,
(SCM cv, SCM v))
(SCM cv, SCM v))
{
if (! CONDVP(cv)) STk_error_bad_condv(cv);
CONDV_SPECIFIC(cv) = v;
......@@ -250,7 +245,7 @@ DEFINE_PRIMITIVE("condition-variable-specific-set!", condv_specific_set, subr2,
}
/* ====================================================================== *\
* Initialization ...
* Initialization ...
\* ====================================================================== */
static void print_mutex(SCM mutex, SCM port, int mode)
......@@ -270,14 +265,14 @@ static void print_condv(SCM condv, SCM port, int mode)
/* The stucture which describes the mutex type */
static struct extended_type_descr xtype_mutex = {
"mutex", /* name */
print_mutex /* print function */
"mutex", /* name */
print_mutex /* print function */
};
/* The stucture which describes the condv type */
static struct extended_type_descr xtype_condv = {
"condv", /* name */
print_condv /* print function */
"condv", /* name */
print_condv /* print function */
};
......
/*
* mutex-common.h -- Mutex support for STklos
* mutex-common.h -- Mutex support for STklos
*
* Copyright © 2006-2009 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 4-Feb-2006 11:03 (eg)
* Last file update: 3-Oct-2009 21:46 (eg)
* Last file update: 21-Sep-2018 08:56 (eg)
*/
#ifndef _STK_MUTEX_H
#define _STK_MUTEX_H
......@@ -36,7 +36,7 @@
/* ====================================================================== *\
*
* M U T E X E S
* M U T E X E S
*
\* ====================================================================== */
......@@ -49,15 +49,15 @@ struct mutex_obj {
struct sys_mutex_obj sys_mutex;
};
#define MUTEXP(p) (BOXED_TYPE_EQ((p), tc_mutex))
#define MUTEX_NAME(p) (((struct mutex_obj *) (p))->name)
#define MUTEX_SPECIFIC(p) (((struct mutex_obj *) (p))->specific)
#define MUTEX_OWNER(p) (((struct mutex_obj *) (p))->owner)
#define MUTEX_LOCKED(p) (((struct mutex_obj *) (p))->locked)
#define MUTEXP(p) (BOXED_TYPE_EQ((p), tc_mutex))
#define MUTEX_NAME(p) (((struct mutex_obj *) (p))->name)
#define MUTEX_SPECIFIC(p) (((struct mutex_obj *) (p))->specific)
#define MUTEX_OWNER(p) (((struct mutex_obj *) (p))->owner)
#define MUTEX_LOCKED(p) (((struct mutex_obj *) (p))->locked)
/* ====================================================================== *\
*
* C O N D V A R S
* C O N D V A R S
*
\* ====================================================================== */
......@@ -68,9 +68,9 @@ struct condv_obj {
struct sys_condv_obj sys_condv;
};
#define CONDVP(p) (BOXED_TYPE_EQ((p), tc_condv))
#define CONDV_NAME(p) (((struct condv_obj *) (p))->name)
#define CONDV_SPECIFIC(p) (((struct condv_obj *) (p))->specific)
#define CONDVP(p) (BOXED_TYPE_EQ((p), tc_condv))
#define CONDV_NAME(p) (((struct condv_obj *) (p))->name)
#define CONDV_SPECIFIC(p) (((struct condv_obj *) (p))->specific)
/* ====================================================================== */
......@@ -78,7 +78,6 @@ extern SCM STk_sym_not_owned, STk_sym_abandoned, STk_sym_not_abandoned;
extern void STk_error_bad_mutex(SCM obj);
extern void STk_error_deadlock(void);
extern void STk_error_bad_timeout(SCM tm);
extern void STk_error_bad_condv(SCM obj);
......
/*
* mutex-pthreads.c -- Pthread Mutexes in Scheme
* mutex-pthreads.c -- Pthread Mutexes in Scheme
*
* Copyright © 2006-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
* Copyright © 2006-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 2-Feb-2006 21:58 (eg)
* Last file update: 27-May-2011 22:56 (eg)
* Last file update: 21-Sep-2018 08:47 (eg)
*/
#include <unistd.h>
......@@ -33,7 +33,7 @@
/* ====================================================================== *\
*
* M U T E X E S
* M U T E X E S
*
\* ====================================================================== */
......@@ -140,17 +140,14 @@ doc>
DEFINE_PRIMITIVE("%mutex-lock!", mutex_lock, subr3, (SCM mtx, SCM tm, SCM thread))
{
struct timespec ts;
double tmd;
SCM res = STk_true;
if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
if (REALP(tm)) {
tmd = REAL_VAL(tm);
if (!BOOLEANP(tm)) {
double tmd = STk_verify_timeout(tm);
ts.tv_sec = (time_t) tmd;
ts.tv_nsec = (suseconds_t) ((tmd - ts.tv_sec) * 1000000);
}
else if (!BOOLEANP(tm))
STk_error_bad_timeout(tm);
pthread_cleanup_push((void (*)(void*))mutex_finalizer, mtx);
......@@ -159,7 +156,7 @@ DEFINE_PRIMITIVE("%mutex-lock!", mutex_lock, subr3, (SCM mtx, SCM tm, SCM thread
while (MUTEX_LOCKED(mtx)) {
if ((MUTEX_OWNER(mtx) != STk_false) &&
(THREAD_STATE(MUTEX_OWNER(mtx)) == th_terminated)) {
(THREAD_STATE(MUTEX_OWNER(mtx)) == th_terminated)) {
MUTEX_LOCKED(mtx) = FALSE;
MUTEX_OWNER(mtx) = STk_false;
res = MUTEX_OWNER(mtx);
......@@ -211,18 +208,16 @@ doc>
DEFINE_PRIMITIVE("%mutex-unlock!", mutex_unlock, subr3, (SCM mtx, SCM cv, SCM tm))
{
struct timespec ts;
double tmd;
SCM res = STk_true;
if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
if ((cv != STk_false) && (!CONDVP(cv))) STk_error_bad_condv(cv);
if (REALP(tm)) {
tmd = REAL_VAL(tm);
if (!BOOLEANP(tm)) {
double tmd = STk_verify_timeout(tm);
ts.tv_sec = (time_t) tmd;
ts.tv_nsec = (suseconds_t) ((tmd - ts.tv_sec) * 1000000000);
}
else if (!BOOLEANP(tm))
STk_error_bad_timeout(tm);
pthread_cleanup_push((void (*)(void*))mutex_finalizer, mtx);
......@@ -252,7 +247,7 @@ DEFINE_PRIMITIVE("%mutex-unlock!", mutex_unlock, subr3, (SCM mtx, SCM cv, SCM tm
/* ====================================================================== *\
*
* C O N D V A R S
* C O N D V A R S
*
\* ====================================================================== */
......
/*
* thread-common.c -- Threads support in STklos
* thread-common.c -- Threads support in STklos
*
* Copyright © 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
* Copyright © 2006-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
* (at your option) any later version.mu
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 23-Jan-2006 12:14 (eg)
* Last file update: 27-Oct-2006 14:49 (eg)
* Last file update: 21-Sep-2018 09:15 (eg)
*/
#include <unistd.h>
#include "stklos.h"
......@@ -39,6 +39,13 @@ void STk_error_bad_thread(SCM obj)
STk_error("bad thread ~S", obj);
}
double STk_verify_timeout(SCM tm) {
double res = STk_number2double(tm);
if (isnan(res)) STk_error("bad timeout ~S", tm);
return res;
}
struct timeval STk_thread_abstime_to_reltime(double abs_secs)
{
......@@ -88,7 +95,7 @@ DEFINE_PRIMITIVE("%thread-dynwind-stack", thread_dynwind_stack, subr0, (void))
}
DEFINE_PRIMITIVE("%thread-dynwind-stack-set!", thread_dynwind_stack_set, subr1,
(SCM value))
(SCM value))
{
vm_thread_t *vm = STk_get_current_vm();
vm->dynwind_stack = value;
......@@ -195,7 +202,7 @@ DEFINE_PRIMITIVE("%thread-end-exception", thread_end_exception, subr1, (SCM thr)
}
DEFINE_PRIMITIVE("%thread-end-exception-set!", thread_end_exception_set,
subr2, (SCM thr, SCM val))
subr2, (SCM thr, SCM val))
{
if (!THREADP(thr)) STk_error_bad_thread(thr);
THREAD_EXCEPTION(thr) = val;
......@@ -209,7 +216,7 @@ DEFINE_PRIMITIVE("%thread-end-result", thread_end_result, subr1, (SCM thr))
}
DEFINE_PRIMITIVE("%thread-end-result-set!", thread_end_result_set,
subr2, (SCM thr, SCM val))
subr2, (SCM thr, SCM val))
{
if (!THREADP(thr)) STk_error_bad_thread(thr);
THREAD_RESULT(thr) = val;
......@@ -244,7 +251,7 @@ DEFINE_PRIMITIVE("thread-specific", thread_specific, subr1, (SCM thr))
doc>
*/
DEFINE_PRIMITIVE("thread-specific-set!", thread_specific_set, subr2,
(SCM thr, SCM value))
(SCM thr, SCM value))
{
if (!THREADP(thr)) STk_error_bad_thread(thr);
THREAD_SPECIFIC(thr) = value;
......@@ -293,7 +300,7 @@ DEFINE_PRIMITIVE("thread-start!", thread_start, subr1, (SCM thr))
}
/* ======================================================================
* Initialization ...
* Initialization ...
* ======================================================================
*/
......@@ -321,8 +328,8 @@ static void print_thread(SCM thread, SCM port, int mode)
/* The stucture which describes the thread type */
static struct extended_type_descr xtype_thread = {
"thread", /* name */
print_thread /* print function */
"thread", /* name */
print_thread /* print function */
};
/* ---------------------------------------------------------------------- */
......@@ -353,12 +360,12 @@ int STk_init_threads(int stack_size, void *start_stack)
/* Wrap the main thread in a thread called "primordial" */
primordial = do_make_thread(STk_false,
STk_Cstring2string("primordial"),
stack_size);
STk_Cstring2string("primordial"),
stack_size);
THREAD_STATE(primordial) = th_runnable;
THREAD_VM(primordial) = vm;
vm->scheme_thread = primordial;
vm->start_stack = start_stack;
vm->start_stack = start_stack;
STk_primordial_thread = primordial;
/* Thread primitives */
......
/*
* thread-common.h -- Thread support for STklos
* thread-common.h -- Thread support for STklos
*
* Copyright © 2006-2009 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
* Copyright © 2006-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,11 +21,12 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 4-Feb-2006 11:03 (eg)
* Last file update: 3-Oct-2009 21:47 (eg)
* Last file update: 21-Sep-2018 09:19 (eg)
*/
#ifndef _STK_THREAD_H
#define _STK_THREAD_H
#include <math.h> /* for isnan */
#include "stklos.h"
#if defined(THREADS_PTHREADS)
......@@ -52,17 +53,18 @@ struct thread_obj {
};
#define THREADP(p) (BOXED_TYPE_EQ((p), tc_thread))
#define THREAD_THUNK(p) (((struct thread_obj *) (p))->thunk)
#define THREAD_NAME(p) (((struct thread_obj *) (p))->name)
#define THREAD_SPECIFIC(p) (((struct thread_obj *) (p))->specific)
#define THREAD_RESULT(p) (((struct thread_obj *) (p))->end_result)
#define THREAD_EXCEPTION(p) (((struct thread_obj *) (p))->end_exception)
#define THREAD_STATE(p) (((struct thread_obj *) (p))->state)
#define THREAD_STACK_SIZE(p) (((struct thread_obj *) (p))->stack_stize)
#define THREAD_VM(p) (((struct thread_obj *) (p))->vm)
#define THREADP(p) (BOXED_TYPE_EQ((p), tc_thread))
#define THREAD_THUNK(p) (((struct thread_obj *) (p))->thunk)
#define THREAD_NAME(p) (((struct thread_obj *) (p))->name)
#define THREAD_SPECIFIC(p) (((struct thread_obj *) (p))->specific)
#define THREAD_RESULT(p) (((struct thread_obj *) (p))->end_result)
#define THREAD_EXCEPTION(p) (((struct thread_obj *) (p))->end_exception)
#define THREAD_STATE(p) (((struct thread_obj *) (p))->state)
#define THREAD_STACK_SIZE(p) (((struct thread_obj *) (p))->stack_stize)
#define THREAD_VM(p) (((struct thread_obj *) (p))->vm)
extern void STk_error_bad_thread(SCM obj);
double STk_verify_timeout(SCM tm);
extern SCM STk_cond_thread_terminated;
......
/*
* thread-pthreads.c -- Threads support in STklos
* thread-pthreads.c -- Threads support in STklos
*
* Copyright © 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
* Copyright © 2006-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 23-Jan-2006 12:14 (eg)
* Last file update: 27-May-2011 22:55 (eg)
* Last file update: 21-Sep-2018 09:15 (eg)
*/
......@@ -190,10 +190,10 @@ DEFINE_PRIMITIVE("thread-terminate!", thread_terminate, subr1, (SCM thr))
}
/* Terminate effectively the thread */
if (thr == STk_get_current_vm()->scheme_thread)
pthread_exit(0); /* Suicide */
pthread_exit(0); /* Suicide */
else {
if (saved_state != th_new)
pthread_cancel(THREAD_PTHREAD(thr)); /* terminate an other thread */
pthread_cancel(THREAD_PTHREAD(thr)); /* terminate an other thread */
}
pthread_mutex_unlock(&THREAD_MYMUTEX(thr));
}
......@@ -225,25 +225,22 @@ DEFINE_PRIMITIVE("%thread-join!", thread_join, subr2, (SCM thr, SCM tm))
{
struct timespec ts;
SCM res = STk_false;
double tmd;
if (!THREADP(thr)) STk_error_bad_thread(thr);
if (REALP(tm)) {
tmd = REAL_VAL(tm);
if (!BOOLEANP(tm)) {
double tmd = STk_verify_timeout(tm);
ts.tv_sec = (time_t) tmd;
ts.tv_nsec = (suseconds_t) ((tmd - ts.tv_sec) * 1000000);
}
else if (!BOOLEANP(tm))
STk_error("bad timeout ~S", tm);
pthread_mutex_lock(&THREAD_MYMUTEX(thr));
while (THREAD_STATE(thr) != th_terminated) {
if (tm != STk_false) {
int n = pthread_cond_timedwait(&THREAD_MYCONDV(thr),
&THREAD_MYMUTEX(thr),
&ts);
&THREAD_MYMUTEX(thr),
&ts);
if (n == ETIMEDOUT) { res = STk_true; break; }
}
else
......@@ -264,8 +261,10 @@ doc>
*/
DEFINE_PRIMITIVE("%thread-sleep!", thread_sleep, subr1, (SCM tm))
{
if (REALP(tm)) {
struct timeval tv = STk_thread_abstime_to_reltime(REAL_VAL(tm));
double tmd = STk_number2double(tm);
if (isnan(tmd)) {
struct timeval tv = STk_thread_abstime_to_reltime(tmd);
struct timespec ts;
/* convert a timeval (in µs) to a timesepc (in ns) */
......@@ -285,7 +284,7 @@ DEFINE_PRIMITIVE("%thread-system", thread_system, subr0, (void))
}
/* ======================================================================
* Initialization ...
* Initialization ...
* ======================================================================
*/
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment