Commit 9dfd95d3 authored by eg's avatar eg

first version with threads - No lock on globals yet

parent c391ba14
2006-02-03 Erick Gallesio <eg@essi.fr>
* src/system.c: primitive CURRENT-TIME as been renamed to
CURRENT-SECOND. to be compliant with SRFI-18.
* A bunch of new functions have been added for time.
2006-02-01 Erick Gallesio <eg@essi.fr>
* src/stklos.h:
......
......@@ -18,7 +18,7 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 3-Jan-2006 16:24 (eg)
;; Last file update: 3-Feb-2006 17:54 (eg)
;;
;; ======================================================================
......@@ -580,12 +580,12 @@ representation which consists is an integer which represents the
number of seconds elapsed since the ,(emph "Epoch") (00:00:00 on
January 1, 1970, Coordinated Universal Time --UTC). Dates can
also be represented with date structures.])
(insertdoc 'current-second)
(insertdoc 'current-time)
(insertdoc 'full-current-time)
(insertdoc 'seconds->date)
(insertdoc 'seconds->string)
(insertdoc 'seconds->list)
(insertdoc 'time?)
(insertdoc 'time->seconds)
(insertdoc 'seconds->time)
(insertdoc 'current-date)
(insertdoc 'make-date)
(insertdoc 'date?)
......@@ -601,6 +601,10 @@ also be represented with date structures.])
(insertdoc 'date-tz)
(insertdoc 'date->seconds)
(insertdoc 'date->string)
(insertdoc 'seconds->date)
(insertdoc 'seconds->string)
(insertdoc 'seconds->list)
(insertdoc 'date)
)
......
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 15-Dec-2005 20:24 (eg)
# Last file update: 3-Feb-2006 16:32 (eg)
SUBDIRS = Match.d SILex.d Lalr.d
......@@ -12,6 +12,7 @@ scheme_BOOT = assembler.stk \
boot.stk \
compiler.stk \
computils.stk \
date.stk \
expand.pp \
load.stk \
mbe.stk \
......
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 15-Dec-2005 20:24 (eg)
# Last file update: 3-Feb-2006 16:32 (eg)
SHELL = @SHELL@
srcdir = @srcdir@
......@@ -126,6 +126,7 @@ scheme_BOOT = assembler.stk \
boot.stk \
compiler.stk \
computils.stk \
date.stk \
expand.pp \
load.stk \
mbe.stk \
......
;;;;
;;;; date.stk -- Date and Time Operations
;;;;
;;;; Copyright 2002-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2002-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,9 +21,74 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 3-Apr-2002 10:06 (eg)
;;;; Last file update: 29-Nov-2004 11:58 (eg)
;;;; Last file update: 3-Feb-2006 17:47 (eg)
;;;;
;;;; ======================================================================
;;;;
;;;; TIME functions
;;;;
;;;; ======================================================================
#|
<doc EXT time?
* (time? obj)
*
* Return |t| if |obj| is a time object, othererwise returns |f|.
doc>
|#
(define (time? obj)
(and (struct? obj) (eq? (struct-type obj) %time)))
#|
<doc EXT time->seconds
* (time->seconds time)
*
* Convert the time object |time| into an inexact real number representing
* the number of seconds elapsed since the Epoch.
* @lisp
* (time->seconds (current-time)) ==> 1138983411.09337
* @end lisp
doc>
|#
(define (time->seconds time)
(if (time? time)
(+ (%fast-struct-ref time %time 'second 0)
(/ (%fast-struct-ref time %time 'micro-second 1) 1e6))
(error 'time-seconds "bad time ~S" time)))
#|
<doc EXT seconds->time
* (seconds->time x)
*
* Converts into a time object the real number |x| representing the number
* of seconds elapsed since the Epoch.
* @lisp
* (seconds->time (+ 10 (time->seconds (current-time)))
* ==> a time object representing 10 seconds in the future
* @end lisp
doc>
|#
(define (seconds->time x)
(if (and (number? x) (positive? x))
(cond
((real? x)
(let ((n (inexact->exact (round (* x 1e6)))))
(make-struct %time (quotient n 1000000) (remainder n 1000000))))
((integer? x)
(make-struct %time x 0))
(else
(error 'seconds->time "cannot convert ~S to a time" x)))
(error 'seconds->time "bad number ~S" x)))
;;;; ======================================================================
;;;;
;;;; DATE functions
;;;;
;;;; ======================================================================
#|
<doc EXT make-date
* (make-date :key second minute hour day month year)
......@@ -49,6 +114,11 @@ doc>
(define (date? obj)
(and (struct? obj) (eq? (struct-type obj) %date)))
(define (seconds->date s)
(%seconds->date (if (real? s) (inexact->exact (round s)) s)))
;; ======================================================================
;; date writer
;; ======================================================================
......@@ -152,7 +222,7 @@ doc>
* (UTC) and local standard time in seconds.])
* )
* @lisp
* (seconds->list (current-time))
* (seconds->list (current-second))
* => (:second 51 :minute 26 :hour 19
* :day 5 :month 11 :year 2004
* :week-day 5 :year-day 310
......@@ -174,8 +244,7 @@ doc>
doc>
|#
(define (current-date)
(seconds->date (current-time)))
(seconds->date (current-second)))
#|
<doc EXT seconds->string
......@@ -234,7 +303,8 @@ doc>
(error 'seconds->string "bad string ~S" format))
;; Convert the format string for C since conventions are different
(let ((len (string-length format))
(out (open-output-string)))
(out (open-output-string))
(sec (if (real? seconds) (inexact->exact (round seconds)) seconds)))
(let Loop ((i 0))
(when (< i len)
(let ((cur-char (string-ref format i)))
......@@ -253,13 +323,13 @@ doc>
(else (display cur-char out)
(Loop (+ i 1)))))))
;; String is converted in the "OUT" string port
(%seconds->string (get-output-string out) seconds)))
(%seconds->string (get-output-string out) sec)))
#|
<doc EXT date->string
* (date->string format d)
*
* Convert the date |d|using the string |format| as a
* Convert the date |d| using the string |format| as a
* specification. Conventions for format are the same as the one
* of ,(ref :mark "seconds->string").
doc>
......@@ -271,5 +341,6 @@ doc>
(seconds->string format (date->seconds date)))
(provide "date")
This diff is collapsed.
This diff is collapsed.
......@@ -21,15 +21,16 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 2-Feb-2006 21:58 (eg)
* Last file update: 3-Feb-2006 10:55 (eg)
* Last file update: 5-Feb-2006 21:52 (eg)
*/
#define _REENTRANT 1
#define GC_LINUX_THREADS 1
#include <pthread.h>
#include <unistd.h>
#include "stklos.h"
#include "vm.h"
#include "thread.h"
static SCM sym_not_owned, sym_abandoned, sym_not_abandoned;
......@@ -64,6 +65,17 @@ void error_bad_mutex(SCM obj)
STk_error("bad mutex ~S", obj);
}
void error_deadlock(void)
{
STk_error("cannot lock mutex (deadlock will occur)");
}
void error_bad_timeout(SCM tm)
{
STk_error("bad timeout ~S", tm);
}
void mutex_finalizer(SCM mtx)
{
STk_debug("Finalizer mutex ~S", mtx);
......@@ -87,7 +99,7 @@ DEFINE_PRIMITIVE("make-mutex", make_mutex, subr01, (SCM name))
NEWCELL(z, mutex);
MUTEX_NAME(z) = name;
MUTEX_SPECIFIC(z) = STk_void;
MUTEX_OWNER(z) = STk_void;
MUTEX_OWNER(z) = STk_false;
MUTEX_LOCKED(z) = FALSE;
pthread_mutex_init(&MUTEX_MYMUTEX(z), NULL);
......@@ -132,9 +144,9 @@ DEFINE_PRIMITIVE("mutex-state", mutex_state, subr1, (SCM mtx))
pthread_mutex_lock(&MUTEX_MYMUTEX(mtx));
if (MUTEX_LOCKED(mtx))
res = (MUTEX_OWNER(mtx) == STk_void) ? sym_not_owned : MUTEX_OWNER(mtx);
res = (MUTEX_OWNER(mtx) == STk_false) ? sym_not_owned : MUTEX_OWNER(mtx);
else
res = (MUTEX_OWNER(mtx) == STk_void) ? sym_not_abandoned: sym_abandoned;
res = (MUTEX_OWNER(mtx) == STk_false) ? sym_not_abandoned: sym_abandoned;
pthread_mutex_unlock(&MUTEX_MYMUTEX(mtx));
......@@ -142,6 +154,99 @@ DEFINE_PRIMITIVE("mutex-state", mutex_state, subr1, (SCM mtx))
}
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)) error_bad_mutex(mtx);
if (REALP(tm)) {
tmd = REAL_VAL(tm);
ts.tv_sec = (time_t) tmd;
ts.tv_nsec = (suseconds_t) ((tmd - ts.tv_sec) * 1000000);
}
else if (!BOOLEANP(tm))
error_bad_timeout(tm);
pthread_cleanup_push((void (*)(void*))mutex_finalizer, mtx);
if (pthread_mutex_lock(&MUTEX_MYMUTEX(mtx)) != 0)
error_deadlock();
while (MUTEX_LOCKED(mtx)) {
if ((MUTEX_OWNER(mtx) != STk_false) &&
(THREAD_STATE(MUTEX_OWNER(mtx)) == th_terminated)) {
MUTEX_LOCKED(mtx) = FALSE;
MUTEX_OWNER(mtx) = STk_false;
res = MUTEX_OWNER(mtx);
break;
}
if (tm != STk_false) {
int n = pthread_cond_timedwait(&MUTEX_MYCONDV(mtx), &MUTEX_MYMUTEX(mtx), &ts);
if (n == ETIMEDOUT) { STk_debug("TIMEOUT"); res = STk_false; break; }
}
else
pthread_cond_wait(&MUTEX_MYCONDV(mtx), &MUTEX_MYMUTEX(mtx));
}
if (res == STk_true) {
/* We can lock the mutex */
MUTEX_LOCKED(mtx) = TRUE;
MUTEX_OWNER(mtx) = thread;
}
pthread_mutex_unlock(&MUTEX_MYMUTEX(mtx));
pthread_cleanup_pop(0);
/* Different cases for res:
* - The owning thread which is now terminated (a condition must be raised)
* - #f: we had a timeout
* - #t: otherwise
*/
return res;
}
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)) error_bad_mutex(mtx);
if (REALP(tm)) {
tmd = REAL_VAL(tm);
ts.tv_sec = (time_t) tmd;
ts.tv_nsec = (suseconds_t) ((tmd - ts.tv_sec) * 1000000);
}
else if (!BOOLEANP(tm))
error_bad_timeout(tm);
pthread_cleanup_push((void (*)(void*))mutex_finalizer, mtx);
if (pthread_mutex_lock(&MUTEX_MYMUTEX(mtx)) != 0)
error_deadlock();
/* Go in the unlocked/abandonned state */
MUTEX_LOCKED(mtx) = FALSE;
MUTEX_OWNER(mtx) = STk_false;
/* Signal to waiting threads */
pthread_cond_signal(&MUTEX_MYCONDV(mtx));
if (cv != STk_false) {
if (tm != STk_false) {
int n = pthread_cond_timedwait(&MUTEX_MYCONDV(mtx), &MUTEX_MYMUTEX(mtx), &ts);
if (n == ETIMEDOUT) res = STk_false;
} else {
pthread_cond_wait(&MUTEX_MYCONDV(mtx), &MUTEX_MYMUTEX(mtx));
}
}
pthread_mutex_unlock(&MUTEX_MYMUTEX(mtx));
pthread_cleanup_pop(0);
return res;
}
/* ====================================================================== *\
*
* C O N D V A R S
......@@ -164,7 +269,7 @@ struct condv_obj {
void error_bad_condv(SCM obj)
{
STk_error("bad confdition variaable ~S", obj);
STk_error("bad confdition variable ~S", obj);
}
void condv_finalizer(SCM cv)
......@@ -297,6 +402,8 @@ int STk_init_mutexes(void)
ADD_PRIMITIVE(mutex_specific);
ADD_PRIMITIVE(mutex_specific_set);
ADD_PRIMITIVE(mutex_state);
ADD_PRIMITIVE(mutex_lock);
ADD_PRIMITIVE(mutex_unlock);
/* Condv primitives */
ADD_PRIMITIVE(make_condv);
......
......@@ -2,7 +2,7 @@
*
* s y s t e m . c -- System relative primitives
*
* Copyright 1994-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 1994-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* Permission to use, copy, modify, distribute,and license this
......@@ -16,7 +16,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 29-Mar-1994 10:57
* Last file update: 6-Jun-2005 22:16 (eg)
* Last file update: 3-Feb-2006 17:12 (eg)
*/
#include <unistd.h>
......@@ -40,10 +40,8 @@
#endif
static SCM exit_procs = STk_nil; /* atexit functions */
static SCM date_type;
static SCM date_type, time_type;
/******************************************************************************
*
......@@ -719,41 +717,40 @@ DEFINE_PRIMITIVE("clock", clock, subr0, (void))
}
/*
<doc EXT current-time
* (current-time)
<doc EXT current-second
* (current-second)
*
* Returns the time since the Epoch (that is 00:00:00 UTC, January 1, 1970),
* measured in seconds.
doc>
*/
DEFINE_PRIMITIVE("current-time", current_time, subr0, (void))
DEFINE_PRIMITIVE("current-second", current_second, subr0, (void))
{
return STk_ulong2integer(time(NULL));
}
/*
<doc EXT full-current-time
* (full-current-time)
*
* Returns the time of the day as a pair where
* ,(itemize
* (item [the first element is the time since the Epoch
* (that is 00:00:00 UTC, January 1, 1970), measured in seconds. ])
<doc current-time
* (current-time)
*
* (item [the second element is the number of microseconds in the given
* second.])
* )
* Returns a time object corresponding to the current time.
doc>
*/
DEFINE_PRIMITIVE("full-current-time", full_current_time, subr0, (void))
DEFINE_PRIMITIVE("current-time", current_time, subr0, (void))
{
struct timeval now;
gettimeofday(&now, NULL);
SCM argv[3];
return STk_cons(STk_long2integer(now.tv_sec),
STk_long2integer(now.tv_usec));
gettimeofday(&now, NULL);
argv[2] = time_type;
argv[1] = STk_long2integer(now.tv_sec);
argv[0] = STk_long2integer(now.tv_usec);
return STk_make_struct(3, &argv[2]);
}
/*
<doc EXT sleep
* (sleep n)
......@@ -788,7 +785,7 @@ DEFINE_PRIMITIVE("sleep", sleep, subr1, (SCM ms))
* to a date.
doc>
*/
DEFINE_PRIMITIVE("seconds->date", seconds2date, subr1, (SCM seconds))
DEFINE_PRIMITIVE("%seconds->date", seconds2date, subr1, (SCM seconds))
{
int overflow;
SCM argv[11];
......@@ -847,7 +844,7 @@ DEFINE_PRIMITIVE("date->seconds", date2seconds, subr1, (SCM date))
n = mktime(&t);
if (n == (time_t)(-1)) STk_error("cannot convert date to seconds (~S)", date);
return STk_ulong2integer((long) n);
return STk_double2real((double) n);
}
......@@ -1030,7 +1027,6 @@ DEFINE_PRIMITIVE("%chmod", change_mode, subr2, (SCM file, SCM value))
int STk_init_system(void)
{
/* Create the system-date structure-type */
date_type = STk_make_struct_type(STk_intern("%date"),
STk_false,
......@@ -1046,11 +1042,18 @@ int STk_init_system(void)
STk_intern("tz")));
STk_define_variable(STk_intern("%date"), date_type, STk_current_module);
/* Create the time structure-type */
time_type = STk_make_struct_type(STk_intern("%time"),
STk_false,
LIST2(STk_intern("second"),
STk_intern("microsecond")));
STk_define_variable(STk_intern("%time"), time_type, STk_current_module);
/* Declare primitives */
ADD_PRIMITIVE(clock);
ADD_PRIMITIVE(date);
ADD_PRIMITIVE(current_second);
ADD_PRIMITIVE(current_time);
ADD_PRIMITIVE(full_current_time);
ADD_PRIMITIVE(sleep);
ADD_PRIMITIVE(seconds2date);
ADD_PRIMITIVE(date2seconds);
......
......@@ -21,49 +21,20 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 23-Jan-2006 12:14 (eg)
* Last file update: 3-Feb-2006 11:06 (eg)
* Last file update: 5-Feb-2006 21:52 (eg)
*/
#define _REENTRANT 1
#define GC_LINUX_THREADS 1
#include <pthread.h>
#include <unistd.h>
#include "stklos.h"
#include "vm.h"
#include "thread.h"
static SCM primordial, cond_thread_terminated;
enum thread_state { th_new, th_runnable, th_terminated, th_blocked};
struct thread_obj {
stk_header header;
SCM thunk;
SCM name;
SCM specific;
SCM end_result;
SCM end_exception;
enum thread_state state;
vm_thread_t *vm;
pthread_t pthread;
pthread_mutex_t mymutex;
pthread_cond_t mycondv;
};
#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_VM(p) (((struct thread_obj *) (p))->vm)
#define THREAD_PTHREAD(p) (((struct thread_obj *) (p))->pthread)
#define THREAD_MYMUTEX(p) (((struct thread_obj *) (p))->mymutex)
#define THREAD_MYCONDV(p) (((struct thread_obj *) (p))->mycondv)
static SCM primordial;
static SCM cond_thread_terminated, cond_join_timeout, cond_thread_abandonned_mutex;
static SCM all_threads = STk_nil;
......@@ -155,7 +126,7 @@ static SCM do_make_thread(SCM thunk, char *name)
THREAD_STATE(z) = th_new;
// FIX: lock
// all_threads = STk_cons(z, all_threads); /* For the GC */
all_threads = STk_cons(z, all_threads); /* For the GC */
return z;
}
......@@ -282,35 +253,46 @@ DEFINE_PRIMITIVE("thread-terminate!", thread_terminate, subr1, (SCM thr))
if (THREAD_STATE(thr) != th_terminated) {
terminate_scheme_thread(thr);
if (thr == primordial) {
/* Terminate the primordial thread exits the program */
STk_quit(0);
pthread_mutex_lock(&THREAD_MYMUTEX(thr));
if (THREAD_EXCEPTION(thr) == STk_void) {
/* Be sure to register the first canceller only! */
THREAD_EXCEPTION(thr) = STk_make_C_cond(cond_thread_terminated, 1, thr);
}
THREAD_EXCEPTION(thr) = STk_make_C_cond(cond_thread_terminated, 0);
pthread_mutex_lock(&THREAD_MYMUTEX(thr));
/* Terminate effectively the thread */
if (thr == THREAD_VM(thr)->scheme_thread)
pthread_exit(0); /* Suicide */
else
pthread_cancel(THREAD_PTHREAD(thr)); /* terminate an other thread */
pthread_cancel(THREAD_PTHREAD(thr));
}
return STk_void;
}
DEFINE_PRIMITIVE("%thread-join!", thread_join, subr4, (SCM thr, SCM tm1, SCM tm2,
SCM use_time))
DEFINE_PRIMITIVE("%thread-join!", thread_join, subr2, (SCM thr, SCM tm))
{
struct timespec ts;
int overflow;
time_t t1 = STk_integer2uint32(tm1, &overflow);
long t2 = STk_integer2uint32(tm2, &overflow);
SCM res = STk_false;
double tmd;
if (!THREADP(thr)) error_bad_thread(thr);
ts.tv_sec = t1;
ts.tv_nsec = t2;
if (REALP(tm)) {
tmd = REAL_VAL(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) {
STk_debug("On est dans la boucle avec %d", THREAD_STATE(thr));
if (use_time != STk_false) {
STk_debug("thread-join loop state=%d", THREAD_STATE(thr));
if (tm != STk_false) {
int n = pthread_cond_timedwait(&THREAD_MYCONDV(thr),
&THREAD_MYMUTEX(thr),
&ts);
......@@ -327,8 +309,6 @@ DEFINE_PRIMITIVE("%thread-join!", thread_join, subr4, (SCM thr, SCM tm1, SCM tm2
/* ======================================================================
* Initialization ...
* ======================================================================
......@@ -375,7 +355,14 @@ int STk_init_threads(int stack_size)
/* Define the threads exceptions */
cond_thread_terminated = STk_defcond_type("&thread-terminated", STk_false,
STk_nil, STk_current_module);
LIST1(STk_intern("canceller")),
STk_current_module);
cond_thread_abandonned_mutex = STk_defcond_type("&thread-abandonned-mutex",
STk_false,
STk_nil,
STk_current_module);
cond_join_timeout = STk_defcond_type("&thead-join-timeout", STk_false,
STk_nil, STk_current_module);
/* Wrap the main thread in a thread called "primordial" */
primordial = do_make_thread(STk_false, STk_Cstring2string("primordial"));
......
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