Commit 6a312402 authored by Erick Gallesio's avatar Erick Gallesio

Support for call/cc in threads

parent 42f2fc57
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 26-Jan-2006 22:56 (eg)
;;;; Last file update: 25-Apr-2006 19:10 (eg)
;;;; Last file update: 21-Oct-2006 11:31 (eg)
;;;;
(define (%thread-timeout->seconds timeout)
(cond
......@@ -32,14 +32,16 @@
(else (error "bad timeout ~S" timeout))))
(define (make-thread thunk :optional (name (symbol->string (gensym "thread"))))
(define (make-thread thunk :optional (name (symbol->string (gensym "thread")))
stack-size)
(define (thread-handler c)
(%thread-end-exception-set! (current-thread) c)
c)
(%make-thread (lambda ()
(with-handler thread-handler
(thunk)))
name))
name
stack-size))
(define (thread-sleep! timeout)
......
This diff is collapsed.
This diff is collapsed.
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 5-Jan-2000 12:17 (eg)
* Last file update: 5-Sep-2006 12:02 (eg)
* Last file update: 21-Oct-2006 10:59 (eg)
*/
......@@ -30,44 +30,45 @@
int STk_library_initialized = FALSE; /* True when successfully initialized */
void *STk_start_stack;
int
STk_init_library(int *argc, char ***argv, int stack_size)
{
STk_get_stack_pointer(&STk_start_stack);
void * start_stack;
STk_get_stack_pointer(&start_stack);
return
STk_init_env() &&
STk_init_symbol() &&
STk_late_init_env() &&
STk_init_struct() &&
STk_init_cond() &&
STk_init_vm() &&
STk_init_threads(stack_size)&&
STk_init_port() &&
STk_init_extend() &&
STk_init_list() &&
STk_init_vector() &&
STk_init_uniform_vector() &&
STk_init_char() &&
STk_init_keyword() &&
STk_init_string() &&
STk_init_parameter() &&
STk_init_proc() &&
STk_init_boolean() &&
STk_init_reader() &&
STk_init_system() &&
STk_init_mutexes() &&
STk_init_number() &&
STk_init_hash() &&
STk_init_misc() &&
STk_init_signal() &&
STk_init_promise() &&
STk_init_regexp() &&
STk_init_process() &&
STk_init_socket() &&
STk_init_object() &&
STk_init_base64() &&
STk_init_env() &&
STk_init_symbol() &&
STk_late_init_env() &&
STk_init_struct() &&
STk_init_cond() &&
STk_init_vm() &&
STk_init_threads(stack_size, start_stack) &&
STk_init_port() &&
STk_init_extend() &&
STk_init_list() &&
STk_init_vector() &&
STk_init_uniform_vector() &&
STk_init_char() &&
STk_init_keyword() &&
STk_init_string() &&
STk_init_parameter() &&
STk_init_proc() &&
STk_init_boolean() &&
STk_init_reader() &&
STk_init_system() &&
STk_init_mutexes() &&
STk_init_number() &&
STk_init_hash() &&
STk_init_misc() &&
STk_init_signal() &&
STk_init_promise() &&
STk_init_regexp() &&
STk_init_process() &&
STk_init_socket() &&
STk_init_object() &&
STk_init_base64() &&
(STk_library_initialized = TRUE);
}
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 12-May-1993 10:34
* Last file update: 30-Dec-2005 21:41 (eg)
* Last file update: 21-Oct-2006 11:00 (eg)
*/
......@@ -2938,7 +2938,7 @@ doc>
DEFINE_PRIMITIVE("decode-float", decode_float, subr1, (SCM n))
{
SCM tmp;
int exp, sign;
int exp, sign=0;
if (!NUMBERP(n)) error_bad_number(n);
if (COMPLEXP(n)) STk_error("real number expected. It was ~S", n);
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 26-Sep-2006 13:26 (eg)
* Last file update: 20-Oct-2006 20:40 (eg)
*/
#ifndef STKLOS_H
......@@ -479,9 +479,8 @@ int STk_init_keyword(void);
------------------------------------------------------------------------------
*/
extern int STk_library_initialized; /* True when successfully initialized */
extern void *STk_start_stack; /* An approx. of main thread stack addr */
int STk_init_library(int *argc, char ***argv, int stack_size);
int STk_init_library(int *argc, char ***argv, int stack_size);
/*
------------------------------------------------------------------------------
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 23-Jan-2006 12:14 (eg)
* Last file update: 26-Apr-2006 16:18 (eg)
* Last file update: 21-Oct-2006 13:02 (eg)
*/
#include <unistd.h>
#include "stklos.h"
......@@ -71,33 +71,43 @@ DEFINE_PRIMITIVE("current-thread", current_thread, subr0, (void))
return vm->scheme_thread;
}
static SCM do_make_thread(SCM thunk, SCM name)
static SCM do_make_thread(SCM thunk, SCM name, int stack_size)
{
SCM z;
NEWCELL(z, thread);
THREAD_THUNK(z) = thunk;
THREAD_NAME(z) = name;
THREAD_SPECIFIC(z) = STk_void;
THREAD_RESULT(z) = STk_void;
THREAD_EXCEPTION(z) = STk_false;
THREAD_STATE(z) = th_new;
THREAD_VM(z) = NULL;
THREAD_THUNK(z) = thunk;
THREAD_NAME(z) = name;
THREAD_SPECIFIC(z) = STk_void;
THREAD_RESULT(z) = STk_void;
THREAD_EXCEPTION(z) = STk_false;
THREAD_STATE(z) = th_new;
THREAD_STACK_SIZE(z) = stack_size;
THREAD_VM(z) = NULL;
STk_do_make_sys_thread(z);
return z;
}
DEFINE_PRIMITIVE("%make-thread", make_thread, subr12, (SCM thunk, SCM name))
DEFINE_PRIMITIVE("%make-thread", make_thread, subr3,(SCM thunk, SCM name, SCM ssize))
{
SCM z;
int stack_size;
if (STk_procedurep(thunk) == STk_false)
STk_error("bad thunk ~S", thunk);
z = do_make_thread(thunk, (name ? name : STk_false));
if (ssize == STk_false)
/* If no size is specified, use primordial thread stack size */
stack_size = THREAD_STACK_SIZE(STk_primordial_thread);
else {
stack_size = STk_integer_value(ssize);
if (stack_size < 0)
STk_error("bad stack size ~S", ssize);
}
z = do_make_thread(thunk, (name ? name : STk_false), stack_size);
return z;
}
......@@ -165,7 +175,7 @@ DEFINE_PRIMITIVE("thread-start!", thread_start, subr1, (SCM thr))
STk_error("thread has already been started ~S", thr);
vm = STk_get_current_vm();
new = STk_allocate_vm(5000); // FIX:
new = STk_allocate_vm(THREAD_STACK_SIZE(thr));
new->current_module = vm->current_module;
new->iport = vm->iport;
......@@ -215,7 +225,7 @@ static struct extended_type_descr xtype_thread = {
print_thread /* print function */
};
int STk_init_threads(int stack_size)
int STk_init_threads(int stack_size, void *start_stack)
{
vm_thread_t *vm = STk_allocate_vm(stack_size);
SCM primordial;
......@@ -240,10 +250,13 @@ int STk_init_threads(int stack_size)
STk_nil, STk_STklos_module);
/* Wrap the main thread in a thread called "primordial" */
primordial = do_make_thread(STk_false, STk_Cstring2string("primordial"));
primordial = do_make_thread(STk_false,
STk_Cstring2string("primordial"),
stack_size);
THREAD_STATE(primordial) = th_runnable;
THREAD_VM(primordial) = vm;
vm->scheme_thread = primordial;
vm->start_stack = start_stack;
STk_primordial_thread = primordial;
/* Thread primitives */
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 4-Feb-2006 11:03 (eg)
* Last file update: 26-Apr-2006 16:02 (eg)
* Last file update: 21-Oct-2006 12:29 (eg)
*/
#ifndef _STK_THREAD_H
#define _STK_THREAD_H
......@@ -48,6 +48,7 @@ struct thread_obj {
SCM end_result;
SCM end_exception;
enum thread_state state;
int stack_stize;
vm_thread_t *vm;
struct sys_thread_obj sys_thread;
};
......@@ -60,6 +61,7 @@ struct thread_obj {
#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);
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 23-Jan-2006 12:14 (eg)
* Last file update: 4-Aug-2006 09:50 (eg)
* Last file update: 21-Oct-2006 13:08 (eg)
*/
......@@ -83,10 +83,16 @@ static void *start_scheme_thread(void *arg)
{
volatile SCM thr = (SCM) arg;
SCM res;
void * start_stack;
/* Get the stack start address and place it in the thread (for call/cc) */
STk_get_stack_pointer(&start_stack);
THREAD_VM(thr)->start_stack = start_stack;
pthread_setspecific(vm_key, THREAD_VM(thr));
pthread_cleanup_push(terminate_scheme_thread, thr);
res = STk_C_apply(THREAD_THUNK(thr), 0);
if (THREAD_EXCEPTION(thr) == STk_false) {
THREAD_RESULT(thr) = res;
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 27-Sep-2006 13:41 (eg)
* Last file update: 21-Oct-2006 13:01 (eg)
*/
// INLINER values
......@@ -144,6 +144,7 @@ vm_thread_t *STk_allocate_vm(int stack_size)
vm->env = vm->current_module;
vm->handlers = NULL;
vm->top_jmp_buf = NULL;
vm->start_stack = 0; /* MUST be initialized later */
vm->scheme_thread = STk_false;
vm->parameters = STk_nil;
......@@ -1557,19 +1558,21 @@ DEFINE_PRIMITIVE("%make-continuation", make_continuation, subr0, (void))
vm_thread_t *vm = STk_get_current_vm();
int csize, ssize;
void *cstart, *sstart, *cend, *send;
void *addr;
void *addr, *start_stack;
/* Determine the size of the C stack and the start address */
STk_get_stack_pointer(&addr);
if ((unsigned long) addr < (unsigned long) STk_start_stack) {
csize = (unsigned long) STk_start_stack - (unsigned long) addr;
start_stack = vm->start_stack;
if ((unsigned long) addr < (unsigned long) start_stack) {
csize = (unsigned long) start_stack - (unsigned long) addr;
cstart = addr;
cend = STk_start_stack;
cend = start_stack;
} else {
csize = (unsigned long) addr - (unsigned long) STk_start_stack;
cstart = STk_start_stack;
csize = (unsigned long) addr - (unsigned long) start_stack;
cstart = start_stack;
cend = addr;
}
......@@ -1626,7 +1629,10 @@ DEFINE_PRIMITIVE("%make-continuation", make_continuation, subr0, (void))
static void restore_cont_jump(struct continuation_obj *k, void* addr){
char buf[1024];
int cur_stack_size = STk_start_stack - addr;
vm_thread_t *vm = STk_get_current_vm();
int cur_stack_size;
cur_stack_size = vm->start_stack - addr;
buf[42] = 0x2a;
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 12-Apr-2006 15:57 (eg)
* Last file update: 21-Oct-2006 13:02 (eg)
*/
......@@ -105,6 +105,7 @@ typedef struct {
int valc; /* # of multiple values */
jbuf *top_jmp_buf;
void *start_stack;
SCM *stack;
int stack_len;
......
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