George Peter Staplin Oct 12, 2007 - I wanted co-routines from the C level, so I implemented some C code using the ucontext functions. Unfortunately Tcl's stack checking in unix-like systems breaks this, so you'll need to build a custom tclsh by editing tcl/unix/tclUnixInit.c and changing #undef TCL_NO_STACK_CHECK to #define TCL_NO_STACK_CHECK. The stack checking is somewhat of a hack IMO anyway.
Basically with the ucontext functions each coroutine has a separate stack. It's much cleaner and more reliable than trying to work with setjmp and longjmp.
George Peter Staplin Nov 13, 2007 - The Tcl core now works better with this. I've also built a new version 0.2. I've added the ability for coroutines to have mailboxes (inspired by Erlang).
LV Sir, with regards to your Nov 13th comment - does this mean that a custom tclsh is no longer required to make use of Tcor?
George Peter Staplin - Unfortunately as long as the broken stack checking remains in Tcl, this must require compiling Tcl with -DTCL_NO_STACK_CHECK. The HEAD has been fixed so that it doesn't do #undef in the C sources.
export CC="gcc -DTCL_NO_STACK_CHECK"; ./configure
MS notes that since 8.6a2 the Tcl core does not do the stack checks, so that this should be work on a standard Tcl build. The core also has its own (different, possibly less powerful) coroutine implementation.
/*
Tcor 0.2 by George Peter Staplin
gcc -shared tcor.c -DUSE_TCL_STUBS -I/usr/local/lib -L/usr/local/lib -ltclstub8.5 -o tcor.so
*/
#include <tcl.h>
#include <stdlib.h>
#include <string.h>
#include <ucontext.h>
#define OBJ_CMD_ARGS ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]
#define defcmd(func,name) \
Tcl_CreateObjCommand (interp, name, func, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL)
#define STACK_SIZE 4194304 /* 4 MB */
#define REAPER_STACK_SIZE 1048576 /* 1 MB */
struct lwt_message {
unsigned char *bytes;
size_t length;
struct lwt_message *next;
};
struct lwt {
ucontext_t context;
struct lwt_message *messages;
int id;
void *ptr;
};
static int lwt_initialized = 0;
static struct lwt **lwt_table = NULL;
static int lwt_allocated = 0;
static struct lwt *lwt_current = NULL;
static struct lwt *lwt_to_free = NULL;
static int lwt_total = 0;
static ucontext_t lwt_reaper;
static struct lwt *lwt_alloc (void);
static void lwt_enlarge_table (void);
static void lwt_exit (void);
static void lwt_init (void);
static int lwt_spawn (void (*func) (void), void *ptr);
static void lwt_yield (void);
static int tcor_spawn (OBJ_CMD_ARGS);
static int tcor_yield (OBJ_CMD_ARGS);
static int tcor_send_message (OBJ_CMD_ARGS);
static int tcor_get_message (OBJ_CMD_ARGS);
int Tcor_Init (Tcl_Interp *interp);
static struct lwt *
lwt_alloc (void) {
struct lwt *l;
l = (void *)Tcl_Alloc (sizeof *l);
if (getcontext (&l->context))
perror ("getcontext");
l->messages = NULL;
l->id = -1;
l->ptr = NULL;
return l;
}
static void
lwt_enlarge_table (void) {
struct lwt **newtable;
int newtablesize = lwt_allocated * 2;
int i;
newtable = (void *)Tcl_Alloc (sizeof *newtable * newtablesize);
for (i = 0; i < newtablesize; ++i) {
newtable[i] = NULL;
}
for (i = 0; i < lwt_allocated; ++i) {
newtable[i] = lwt_table[i];
}
Tcl_Free ((void *)lwt_table);
lwt_table = newtable;
lwt_allocated = newtablesize;
}
static void
lwt_reap (void) {
struct lwt *n;
int i;
free (lwt_to_free->context.uc_stack.ss_sp);
Tcl_Free ((void *)lwt_to_free);
lwt_to_free = NULL;
/* Select a new task */
for (i = 0; i < lwt_allocated; ++i) {
if (lwt_table[i]) {
n = lwt_table[i];
break;
}
}
lwt_current = n;
if (setcontext (&n->context)) {
perror ("lwt_exit - setcontext");
abort ();
}
/* NOTREACHED */
}
static void
lwt_exit (void) {
struct lwt *l = lwt_current;
lwt_table[l->id] = NULL;
lwt_to_free = l;
--lwt_total;
/* We can't just free the task now, because it's executing with the stack */
if (setcontext (&lwt_reaper)) {
perror ("lwt_exit - setcontext");
abort ();
}
/* NOTREACHED */
}
static void
lwt_init ( void ) {
struct lwt *l;
int i;
if (lwt_initialized)
return;
l = lwt_alloc ();
lwt_allocated = 20;
lwt_table = (void *)Tcl_Alloc (sizeof *lwt_table * lwt_allocated);
for (i = 0; i < lwt_allocated; ++i) {
lwt_table[i] = NULL;
}
l->id = 0;
lwt_table[/*id*/ 0] = l;
lwt_current = l;
++lwt_total;
l->context.uc_link = NULL;
l->context.uc_stack.ss_size = 0;
l->context.uc_stack.ss_sp = NULL;
if (getcontext (&lwt_reaper)) {
perror ("lwt_init - getcontext lwt_reaper");
abort ();
}
lwt_reaper.uc_link = NULL;
lwt_reaper.uc_stack.ss_sp = malloc (STACK_SIZE);
if (NULL == lwt_reaper.uc_stack.ss_sp) {
perror ("malloc lwt_reaper stack");
abort ();
}
lwt_reaper.uc_stack.ss_flags = 0;
lwt_reaper.uc_stack.ss_size = STACK_SIZE;
makecontext (&lwt_reaper, lwt_reap, 0);
lwt_initialized = 1;
}
static int
lwt_spawn ( void (*func) (void), void *ptr) {
struct lwt *l;
int id;
l = lwt_alloc ();
l->ptr = ptr;
++lwt_total;
if (lwt_total >= lwt_allocated) {
lwt_enlarge_table ();
}
/* Find first free entry */
for (id = 0; id < lwt_allocated; ++id) {
if (NULL == lwt_table[id]) {
break;
}
}
lwt_table[id] = l;
l->id = id;
if (getcontext (&l->context)) {
perror ("getcontext");
abort ();
}
l->context.uc_link = NULL;
l->context.uc_stack.ss_sp = malloc (STACK_SIZE);
if (NULL == l->context.uc_stack.ss_sp) {
perror ("lwt_spawn - malloc stack");
abort ();
}
l->context.uc_stack.ss_flags = 0;
l->context.uc_stack.ss_size = STACK_SIZE;
makecontext (&l->context, func, 0);
return id;
}
static void
lwt_yield ( void ) {
struct lwt *l = lwt_current;
struct lwt *n = NULL;
int id = -1;
id = l->id + 1;
while (id < lwt_allocated) {
if (lwt_table[id]) {
n = lwt_table[id];
break;
}
++id;
}
if (NULL == n) {
for (id = 0; id < lwt_allocated; ++id) {
if (lwt_table[id]) {
n = lwt_table[id];
break;
}
}
}
lwt_current = n;
if (l == n) {
/* There is only one context. */
return;
}
if (swapcontext (&l->context, &n->context)) {
perror ("lwt_yield - swapcontext");
abort ();
}
/* NOTREACHED */
}
static void
tcor_spawn_start (void) {
Tcl_Obj *cmd = lwt_current->ptr;
Tcl_Interp *interp;
interp = Tcl_CreateInterp ();
if (TCL_OK != Tcl_Init (interp)) {
fprintf (stderr, "Tcl_Init error: %s\n", Tcl_GetStringResult (interp));
goto error;
}
if (TCL_OK != Tcor_Init (interp)) {
fprintf (stderr, "Tcl_Init error: %s\n", Tcl_GetStringResult (interp));
goto error;
}
if (TCL_ERROR == Tcl_EvalObjEx (interp, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT)) {
fprintf (stderr, "spawned task evaluation error: %s\n", Tcl_GetStringResult (interp));
}
error:
Tcl_DecrRefCount (cmd);
Tcl_DeleteInterp (interp);
lwt_exit ();
}
static int
tcor_spawn (OBJ_CMD_ARGS) {
Tcl_Obj *cmd;
int id;
if (2 != objc) {
Tcl_WrongNumArgs (interp, 1, objv, "script");
return TCL_ERROR;
}
cmd = Tcl_DuplicateObj (objv[1]);
Tcl_IncrRefCount (cmd);
Tcl_SetObjResult (interp, Tcl_NewIntObj (lwt_spawn (tcor_spawn_start, cmd)));
return TCL_OK;
}
static int
tcor_yield (OBJ_CMD_ARGS) {
if (1 != objc) {
Tcl_WrongNumArgs (interp, 1, objv, "");
return TCL_ERROR;
}
lwt_yield ();
return TCL_OK;
}
static struct lwt *tcor_get_lwt (Tcl_Interp *interp, Tcl_Obj *obj, int *id) {
struct lwt *l;
if (TCL_OK != Tcl_GetIntFromObj (interp, obj, id))
return NULL;
if (*id < 0 || *id >= lwt_allocated) {
Tcl_SetResult (interp, "id out of range", TCL_STATIC);
return NULL;
}
l = lwt_table[*id];
if (NULL == l) {
Tcl_SetResult (interp, "id is invalid", TCL_STATIC);
return NULL;
}
return l;
}
static int
tcor_send_message (OBJ_CMD_ARGS) {
struct lwt *l;
struct lwt_message *m;
unsigned char *b;
int len;
int id;
if (3 != objc) {
Tcl_WrongNumArgs (interp, 1, objv, "id obj");
return TCL_ERROR;
}
l = tcor_get_lwt (interp, objv[1], &id);
if (NULL == l)
return TCL_ERROR;
b = Tcl_GetByteArrayFromObj (objv[2], &len);
m = (void *)Tcl_Alloc (sizeof *m);
m->bytes = (void *)Tcl_Alloc (len);
m->length = len;
memcpy (m->bytes, b, len);
m->next = NULL;
if (NULL == l->messages) {
l->messages = m;
} else {
struct lwt_message *mi;
mi = l->messages;
while (mi->next) {
mi = mi->next;
}
mi->next = m;
}
return TCL_OK;
}
static int
tcor_get_message (OBJ_CMD_ARGS) {
int id;
struct lwt *l;
Tcl_Obj *r;
if (1 != objc) {
Tcl_WrongNumArgs (interp, 1, objv, "");
return TCL_ERROR;
}
again:
l = lwt_current;
if (NULL == l->messages) {
lwt_yield ();
goto again;
} else {
struct lwt_message *m = l->messages;
r = Tcl_NewByteArrayObj (m->bytes, m->length);
l->messages = m->next;
Tcl_Free ((void *)m->bytes);
Tcl_Free ((void *)m);
}
Tcl_SetObjResult (interp, r);
return TCL_OK;
}
int Tcor_Init (Tcl_Interp *interp) {
if (NULL == Tcl_InitStubs (interp, TCL_VERSION, 0))
return TCL_ERROR;
if (TCL_ERROR == Tcl_PkgProvide (interp, "tcor", "0.2"))
return TCL_ERROR;
defcmd (tcor_spawn, "tcor-spawn");
defcmd (tcor_yield, "tcor-yield");
defcmd (tcor_send_message, "tcor-send-message");
defcmd (tcor_get_message, "tcor-get-message");
lwt_init ();
return TCL_OK;
}New test code:
set dir [file dirname [info script]]
load [file join $dir tcor.so]
package require Tk
set bozo {
proc bozo {} {
while 1 {
puts "BOZO SAYS:[tcor-get-message]"
}
}
bozo
}
set clown {
proc clown {} {
while 1 {
puts "CLOWN SAYS:[tcor-get-message]"
}
}
clown
}
proc main {} {
set bozo [tcor-spawn $::bozo]
set clown [tcor-spawn $::clown]
puts "BOZO:$bozo"
puts "CLOWN:$clown"
pack [button .b -text "Message Bozo!" \
-command [list tcor-send-message $bozo HIHIHIHIHIHIHI!]]
pack [button .b2 -text "Message Clown!" \
-command [list tcor-send-message $clown HAHAHAHAHAHA!]]
pack [button .b3 -text Yield \
-command [list tcor-yield]]
}
mainCGM: The previous (now deleted) test code just writes MAIN\nHELLO and then hangs on the vwait. I changed it to:
load ./tcor.so
set cmd {
while 1 {
puts HELLO
tcor-yield
}
}
tcor-spawn $::cmd
while 1 {
puts MAIN
tcor-yield
after 1000
}Which switches between the two loops printing MAIN\nHELLO\nMAIN\nHELLO ...etc.