Commit 68c28dbd authored by eg's avatar eg

better thread support

parent d3f4033a
;;;;
;;;; threads.stk -- Threads support
;;;;
;;;; Copyright 2006 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.
;;;;
;;;; This program 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 General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 26-Jan-2006 22:56 (eg)
;;;; Last file update: 26-Jan-2006 23:03 (eg)
;;;;
(define (thread-sleep! timeout)
(let* ((now (current-time))
(diff (- timeout now)))
(if (> diff 0)
(sleep (* diff 1000)))))
(let ((start (current-time))
(let loop ((x 1))
(thread-sleep! (seconds->time (+ x start)))
(write x)
(loop (+ x 1))))
\ No newline at end of file
/*
This file was automatically generated on Sun Jan 22 19:52:02 2006 by make-C-boot
This file was automatically generated on Thu Jan 26 11:11:35 2006 by make-C-boot
This is a dump of the image in file /mnt/users/eg/Projects/STklos/lib/boot.img3
***DO NOT EDIT BY HAND***
*/
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 5-Jan-2000 12:17 (eg)
* Last file update: 23-Jan-2006 12:15 (eg)
* Last file update: 26-Jan-2006 19:58 (eg)
*/
......@@ -74,7 +74,8 @@ STk_init_library(int *argc, char ***argv, int stack_size)
STk_init_boolean() &&
STk_init_reader() &&
STk_init_system() &&
STk_init_vm(stack_size) &&
STk_init_vm(stack_size) && //FIX: Ne sert pas
STk_init_threads(stack_size)&&
STk_init_hash() &&
STk_init_misc() &&
STk_init_signal() &&
......@@ -83,6 +84,5 @@ STk_init_library(int *argc, char ***argv, int stack_size)
STk_init_process() &&
STk_init_socket() &&
STk_init_object() &&
STk_init_threads() &&
(STk_library_initialized = TRUE);
}
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 23-Jan-2006 13:47 (eg)
* Last file update: 26-Jan-2006 19:54 (eg)
*/
#ifndef STKLOS_H
......
......@@ -21,14 +21,20 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 23-Jan-2006 12:14 (eg)
* Last file update: 23-Jan-2006 14:52 (eg)
* Last file update: 27-Jan-2006 09:12 (eg)
*/
#define _REENTRANT 1
#define GC_LINUX_THREADS 1
#include <pthread.h>
#include <unistd.h>
#include "stklos.h"
#include "vm.h"
enum thread_state { th_new, th_runnable, th_terminated, th_blocked};
struct thread_obj {
stk_header header;
SCM thunk;
......@@ -38,10 +44,12 @@ struct thread_obj {
SCM end_exception;
SCM mutexes;
SCM dynwind;
enum thread_state state;
vm_thread_t *vm;
pthread_t pthread;
};
#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)
......@@ -50,43 +58,94 @@ struct thread_obj {
#define THREAD_EXCEPTION(p) (((struct thread_obj *) (p))->end_exception)
#define THREAD_MUTEXES(p) (((struct thread_obj *) (p))->mutexes)
#define THREAD_DYNWIND(p) (((struct thread_obj *) (p))->dynwind)
#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)
static SCM all_threads = STk_nil;
static void error_bad_thread(SCM obj)
{
STk_error("bad thread ~S", obj);
}
DEFINE_PRIMITIVE("make-thread", make_thread, subr12, (SCM thunk, SCM name))
/*
* Thread specific value (the VM)
*/
static pthread_key_t vm_key;
static void *cleanup_vm_specific(void *p) /* Nothing to do for now */
{
SCM z;
return NULL;
}
if (STk_procedurep(thunk) == STk_false)
STk_error("bad thunk ~S", thunk);
if (name) {
if (!STRINGP(name))
STk_error("bad thread name ~S", name);
static void initialize_vm_key(void)
{
int n = pthread_key_create(&vm_key, (void (*) (void *)) cleanup_vm_specific);
if (n) {
fprintf(stderr, "Cannot initialize the VM specific data\n");
perror("stklos");
exit(1);
}
else name = STk_Cstring2string("");
}
vm_thread_t *STk_get_current_vm(void)
{
return (vm_thread_t *) pthread_getspecific(vm_key);
}
/* ====================================================================== */
static SCM do_make_thread(SCM thunk, char *name)
{
SCM z;
NEWCELL(z, thread);
THREAD_THUNK(z) = name;
THREAD_THUNK(z) = thunk;
THREAD_NAME(z) = name;
THREAD_SPECIFIC(z) = STk_void;
THREAD_RESULT(z) = STk_void;
THREAD_EXCEPTION(z) = STk_false;
THREAD_MUTEXES(z) = STk_nil;
THREAD_DYNWIND(z) = STk_nil;
THREAD_VM(z) = NULL;
THREAD_STATE(z) = th_new;
// FIX: lock
all_threads = STk_cons(z, all_threads); /* For the GC */
return z;
}
DEFINE_PRIMITIVE("current-thread", current_thread, subr0, (void))
{
vm_thread_t *vm = STk_get_current_vm();
return vm->scheme_thread;
}
DEFINE_PRIMITIVE("make-thread", make_thread, subr12, (SCM thunk, SCM name))
{
SCM z;
if (STk_procedurep(thunk) == STk_false)
STk_error("bad thunk ~S", thunk);
if (name) {
if (!STRINGP(name))
STk_error("bad thread name ~S", name);
}
else name = STk_Cstring2string("");
z = do_make_thread(thunk, name);
return z;
}
DEFINE_PRIMITIVE("thread?", threadp, subr1, (SCM obj))
{
STk_debug("===> %x", STk_get_current_vm());
return MAKE_BOOLEAN(THREADP(obj));
}
......@@ -111,26 +170,81 @@ DEFINE_PRIMITIVE("thread-specific-set!", thread_specific_set, subr2,
}
void *start_scheme_thread(void *arg)
static void terminate_scheme_thread(SCM thr)
{
THREAD_STATE(thr) = th_terminated;
// ...........................
}
static void * start_scheme_thread(void *arg)
{
SCM thr = (SCM) arg;
vm_thread_t *vm;
vm = STk_allocate_vm(5000); // FIX:
STk_debug("Dmarrer la thread ~S ~S", thr, THREAD_THUNK(thr));
exit(0);
pthread_setspecific(vm_key, vm);
THREAD_VM(thr) = vm;
vm->scheme_thread = thr;
STk_debug("Ma VM = %x", THREAD_VM(thr), STk_get_current_vm());
THREAD_RESULT(thr) = STk_C_apply(THREAD_THUNK(thr), 0);
terminate_scheme_thread(thr);
}
DEFINE_PRIMITIVE("thread-start", thread_start, subr1, (SCM thr))
DEFINE_PRIMITIVE("thread-start!", thread_start, subr1, (SCM thr))
{
if (!THREADP(thr)) error_bad_thread(thr);
if (THREAD_VM(thr)) STk_error("thread alrady started ~S", thr);
if (!pthread_create(&THREAD_PTHREAD(thr), NULL, start_scheme_thread, thr))
if (THREAD_STATE(thr) != th_new)
STk_error("thread has already been started ~S", thr);
THREAD_STATE(thr) = th_runnable;
if (pthread_create(&THREAD_PTHREAD(thr), NULL, start_scheme_thread, thr))
STk_error("cannot start thread ~S", thr);
return thr;
}
DEFINE_PRIMITIVE("thread-yield!", thread_yield, subr0, (void))
{
#ifdef _POSIX_PRIORITY_SCHEDULING
sched_yield();
#else
/* Do nothing. Is it correct? */
#endif
return STk_void;
}
DEFINE_PRIMITIVE("thread-terminate!", thread_terminate, subr1, (SCM thr))
{
if (!THREADP(thr)) error_bad_thread(thr);
if (THREAD_STATE(thr) != th_terminated) {
terminate_scheme_thread(thr);
THREAD_EXCEPTION(thr) = STk_nil; //FIX:
pthread_cancel(THREAD_PTHREAD(thr));
}
return STk_void;
}
DEFINE_PRIMITIVE("all-threads", all_threads, subr0, (void))
{
/* Use reverse to give a (time creation ordered) copy of our list */
return STk_reverse(all_threads);
}
/* ======================================================================
* Initialization ...
* ======================================================================
......@@ -138,13 +252,21 @@ DEFINE_PRIMITIVE("thread-start", thread_start, subr1, (SCM thr))
static void print_thread(SCM thread, SCM port, int mode)
{
char *name = STRING_CHARS(THREAD_NAME(thread));
char *s, *name = STRING_CHARS(THREAD_NAME(thread));
STk_puts("#[thread ", port);
if (*name)
STk_puts(name, port);
else
STk_fprintf(port, "%lx", (unsigned long) thread);
switch (THREAD_STATE(thread)) {
case th_new: s = "new"; break;
case th_runnable: s = "runnable"; break;
case th_terminated: s = "terminated"; break;
case th_blocked: s = "blocked"; break;
default: s = "???"; break;
}
STk_fprintf(port, " (%s)", s);
STk_putc(']', port);
}
......@@ -156,19 +278,38 @@ static struct extended_type_descr xtype_thread = {
};
int STk_init_threads(void)
int STk_init_threads(int stack_size)
{
vm_thread_t *vm = STk_allocate_vm(stack_size);
SCM primordial;
/* Thread Type declaration */
DEFINE_XTYPE(thread, &xtype_thread);
initialize_vm_key();
pthread_setspecific(vm_key, vm);
/* Wrap the main thread in a thread called "primordial" */
primordial = do_make_thread(STk_false, STk_Cstring2string("primordial"));
THREAD_STATE(primordial) = th_runnable;
THREAD_VM(primordial) = vm;
vm->scheme_thread = primordial;
// all_threads = STk_cons(primordial, all_threads);
/* Thread primitives */
ADD_PRIMITIVE(current_thread);
ADD_PRIMITIVE(make_thread);
ADD_PRIMITIVE(threadp);
ADD_PRIMITIVE(thread_name);
ADD_PRIMITIVE(thread_specific);
ADD_PRIMITIVE(thread_specific_set);
ADD_PRIMITIVE(thread_start);
ADD_PRIMITIVE(thread_yield);
ADD_PRIMITIVE(thread_terminate);
ADD_PRIMITIVE(all_threads);
return TRUE;
}
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 24-Jan-2006 07:50 (eg)
* Last file update: 26-Jan-2006 19:57 (eg)
*/
// INLINER values
......@@ -30,7 +30,6 @@
#define USE_THREADS 1 /* FIX: */
#include "stklos.h"
#include "object.h"
#include "vm.h"
......@@ -118,11 +117,6 @@ static Inline void set_signal_mask(sigset_t mask)
* V M T H R E A D
*
\*===========================================================================*/
#ifdef USE_THREAD
static .......
#endif
static vm_thread_t *the_vm;
vm_thread_t *STk_allocate_vm(int stack_size)
{
vm_thread_t *vm = STk_must_malloc(sizeof(vm_thread_t));
......@@ -145,20 +139,10 @@ vm_thread_t *STk_allocate_vm(int stack_size)
vm->top_jmp_buf = NULL;
vm->scheme_thread = STk_false;
#ifdef USE_THREADS
pthread_key_create(....)
#endif
return vm;
}
vm_thread_t *get_current_vm(void)
{
return the_vm;
}
/*
* Activation records
*
......@@ -309,7 +293,7 @@ static int checked_globals_used = 0;
vm->fp = (SCM *) ACT_SAVE_FP(vm->fp); \
}
static void run_vm(STk_instr *code, SCM *constants, SCM envt);
static void run_vm(vm_thread_t *vm);
/*===========================================================================*\
......@@ -321,7 +305,7 @@ static void run_vm(STk_instr *code, SCM *constants, SCM envt);
#ifdef DEBUG_VM
void STk_print_vm_registers(char *msg, STk_instr *code)
{
vm_thread_t *vm = get_current_vm();
vm_thread_t *vm = STk_get_current_vm();
if (IS_IN_STACKP(vm->env))
STk_fprintf(STk_stderr, "%s VAL=~S PC=%d SP=%d FP=%d CST=%x ENV=%x (%d)\n",
msg, vm->val, vm->pc - code, vm->sp - vm->stack,
......@@ -465,7 +449,7 @@ SCM STk_C_apply(SCM func, int nargs, ...)
{
static STk_instr code[]= {INVOKE, 0, END_OF_CODE};
va_list ap;
vm_thread_t *vm = get_current_vm();
vm_thread_t *vm = STk_get_current_vm();
int i;
va_start(ap, nargs);
......@@ -485,10 +469,11 @@ SCM STk_C_apply(SCM func, int nargs, ...)
for (i = 0; i < nargs; i++) push(va_arg(ap, SCM));
}
vm->val = func; /* Store fun in VAL */
code[1] = (short) nargs; /* Patch # of args */
vm->val = func; /* Store fun in VAL */
vm->pc = code;
run_vm(vm);
run_vm(code, vm->constants, vm->env);
FULL_RESTORE_VM_STATE(vm->sp);
return vm->val;
......@@ -499,7 +484,7 @@ DEFINE_PRIMITIVE("%execute", execute, subr23, (SCM code, SCM consts, SCM envt))
{
int i, len;
STk_instr *vinstr, *p;
vm_thread_t *vm = get_current_vm();
vm_thread_t *vm = STk_get_current_vm();
if (!envt) envt = STk_current_module;
......@@ -515,7 +500,10 @@ DEFINE_PRIMITIVE("%execute", execute, subr23, (SCM code, SCM consts, SCM envt))
*p++ = (STk_instr) STk_integer_value(VECTOR_DATA(code)[i]);
SAVE_VM_STATE();
run_vm(vinstr, VECTOR_DATA(consts), envt);
vm->pc = vinstr;
vm->constants = VECTOR_DATA(consts);
vm->env = envt;
run_vm(vm);
FULL_RESTORE_VM_STATE(vm->sp);
return vm->val;
......@@ -541,7 +529,7 @@ doc>
*/
DEFINE_PRIMITIVE("values", values, vsubr, (int argc, SCM *argv))
{
vm_thread_t *vm = get_current_vm();
vm_thread_t *vm = STk_get_current_vm();
int i;
if (argc == 0)
......@@ -583,7 +571,7 @@ doc>
*/
DEFINE_PRIMITIVE("call-with-values", call_with_values, subr2, (SCM prod, SCM con))
{
vm_thread_t *vm = get_current_vm();
vm_thread_t *vm = STk_get_current_vm();
int tmp;
if (!STk_procedurep(prod)) STk_error("bad producer", prod);
......@@ -607,7 +595,7 @@ DEFINE_PRIMITIVE("call-with-values", call_with_values, subr2, (SCM prod, SCM con
SCM STk_n_values(int n, ...)
{
vm_thread_t *vm = get_current_vm();
vm_thread_t *vm = STk_get_current_vm();
vm->valc = n;
......@@ -669,7 +657,7 @@ static void vm_debug(int kind, vm_thread_t *vm)
DEFINE_PRIMITIVE("%vm-backtrace", vm_bt, subr0, (void))
{
SCM res, *lfp;
vm_thread_t *vm = get_current_vm();
vm_thread_t *vm = STk_get_current_vm();
res = STk_nil;
for (lfp = vm->fp; lfp; lfp = ACT_SAVE_FP(lfp)) {
......@@ -726,9 +714,8 @@ DEFINE_PRIMITIVE("%vm", set_vm_debug, vsubr, (int argc, SCM *argv))
*
\*===========================================================================*/
static void run_vm(STk_instr *code, SCM *consts, SCM envt)
static void run_vm(vm_thread_t *vm)
{
vm_thread_t *vm = get_current_vm();
jbuf jb;
jbuf *old_jb = NULL; /* to make Gcc happy */
short offset, nargs=0;
......@@ -748,11 +735,6 @@ static void run_vm(STk_instr *code, SCM *consts, SCM envt)
static short previous_op = NOP;
#endif
vm->constants = consts;
vm->env = envt;
vm->pc = code;
#if defined(USE_COMPUTED_GOTO)
NEXT;
#else
......@@ -1403,7 +1385,7 @@ end_funcall:
void STk_raise_exception(SCM cond)
{
SCM proc, *save_vm_state;
vm_thread_t *vm = get_current_vm();
vm_thread_t *vm = STk_get_current_vm();
save_vm_state = (vm->handlers) + EXCEPTION_HANDLER_SIZE;
......@@ -1435,7 +1417,6 @@ void STk_raise_exception(SCM cond)
/*
* Return in the good "run_vm" incarnation
*/
//FIX: ?? parenthses
MY_LONGJMP(*(vm->top_jmp_buf), 1);
}
......@@ -1455,7 +1436,7 @@ DEFINE_PRIMITIVE("%make-continuation", make_continuation, subr0, (void))
{
SCM z;
struct continuation_obj *k;
vm_thread_t *vm = get_current_vm();
vm_thread_t *vm = STk_get_current_vm();
int csize, ssize;
void *cstart, *sstart, *cend, *send;
void *addr;
......@@ -1519,7 +1500,7 @@ DEFINE_PRIMITIVE("%make-continuation", make_continuation, subr0, (void))
/* Since we are not sure of the way locals are allocated by the compiler
* we cannot be sure that vm has kept its value. So we get back another
* time the current vm data*/
return get_current_vm()->val;
return STk_get_current_vm()->val;
}
}
......@@ -1531,7 +1512,7 @@ DEFINE_PRIMITIVE("%restore-continuation", restore_cont, subr2, (SCM cont, SCM va
volatile void *p;
void *addr;
int cur_stack_size;
vm_thread_t *vm = get_current_vm();
vm_thread_t *vm = STk_get_current_vm();
if (!CONTP(cont)) STk_error("bad continuation ~S", cont);
......@@ -1659,9 +1640,9 @@ static Inline STk_instr* read_code(SCM f, int len) /* read a code phrase */
SCM STk_load_bcode_file(SCM f)
{
SCM consts, code_size, *save_constants, save_env;
STk_instr *code, *save_pc;
STk_instr *save_pc;
int size;
vm_thread_t *vm = get_current_vm();
vm_thread_t *vm = STk_get_current_vm();
/* Save machine state */
save_pc = vm->pc; save_constants = vm->constants; save_env = vm->env;
......@@ -1680,8 +1661,10 @@ SCM STk_load_bcode_file(SCM f)
return STk_false;
}
code = read_code(f, size); /* Read the code */
run_vm(code, VECTOR_DATA(consts), STk_current_module); /* Execute code read */
vm->pc = read_code(f, size); /* Read the code */
vm->constants = VECTOR_DATA(consts);
vm->env = STk_current_module;
run_vm(vm);
}
/* restore machine state */
......@@ -1713,12 +1696,18 @@ int STk_load_boot(char *filename)
int STk_boot_from_C(void)
{
SCM port, consts;
vm_thread_t *vm = STk_get_current_vm();
/* Get the constants */
port = STk_open_C_string(STk_boot_consts);
consts = STk_read(port, TRUE);
/* Run the VM */
run_vm(STk_boot_code, VECTOR_DATA(consts), STk_current_module);
vm->pc = STk_boot_code;
vm->constants = VECTOR_DATA(consts);
vm->env = STk_current_module;
run_vm(vm);
system_has_booted = 1;
return 0;
}
......@@ -1727,9 +1716,6 @@ int STk_init_vm(int stack_size)
{
DEFINE_XTYPE(continuation, &xtype_continuation);
/* Allocate the main thread */
the_vm = STk_allocate_vm(stack_size);
/* Initialize the table of checked references */
checked_globals = STk_must_malloc(checked_globals_len * sizeof(SCM));
......@@ -1750,3 +1736,4 @@ int STk_init_vm(int stack_size)
#endif
return TRUE;
}
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 23-Jan-2006 13:46 (eg)
* Last file update: 26-Jan-2006 20:20 (eg)
*/
......@@ -100,9 +100,10 @@ typedef struct {
SCM *stack;
int stack_len;
SCM scheme_thread; /* Scheme associated thread */
} vm_thread_t;
vm_thread_t *STk_allocate_vm(int stack_size);
vm_thread_t inline *STk_get_current_vm(void);
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