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.
/* Tcor by George Peter Staplin */
#include <tcl.h>
#include <stdlib.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
struct lwt {
ucontext_t context;
struct lwt *previous, *next;
void *ptr;
};
static struct lwt *lwts = NULL;
static struct lwt *lwt_current = NULL;
static struct lwt *lwt_to_free = NULL;
static int lwt_total = 0;
static ucontext_t lwt_reaper;
static void lwt_exit (void);
static void lwt_init (void);
static void 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);
int Tcor_Init (Tcl_Interp *interp);
static void
lwt_reap (void) {
struct lwt *n;
free (lwt_to_free->context.uc_stack.ss_sp);
free (lwt_to_free);
lwt_to_free = NULL;
n = lwts;
lwt_current = n;
if (setcontext (&n->context)) {
perror ("lwt_exit :- setcontext");
abort ();
}
/* NOTREACHED */
}
static void
lwt_exit (void) {
struct lwt *l = lwt_current;
/* delink the lwt */
if (l->previous) {
l->previous = l->next;
if (l->next) {
l->next->previous = l->previous;
}
} else {
lwts = l->next;
if (lwts) {
lwts->previous = NULL;
}
}
lwt_to_free = l;
if (setcontext (&lwt_reaper)) {
perror ("lwt_exit :- setcontext");
abort ();
}
/* NOTREACHED */
}
static void
lwt_init ( void ) {
struct lwt *l;
l = malloc (sizeof *l);
if (NULL == l) {
perror ("lwt_init :- malloc");
abort ();
}
l->ptr = NULL;
l->previous = NULL;
l->next = lwts;
lwts = l;
lwt_current = l;
++lwt_total;
if (getcontext (&l->context)) {
perror ("lwt_init :- getcontext");
abort ();
}
/* l->context.uc_link = NULL; */
/* From the manual for NetBSD it was unclear if this was necessary or not prior to a makecontext. */
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) {
abort ();
}
lwt_reaper.uc_stack.ss_flags = 0;
lwt_reaper.uc_stack.ss_size = STACK_SIZE;
makecontext (&lwt_reaper, lwt_reap, 0);
}
static void
lwt_spawn ( void (*func) (void), void *ptr) {
struct lwt *l;
l = malloc (sizeof *l);
if (NULL == l) {
perror ("lwt_spawn :- malloc lwt");
abort ();
}
l->ptr = ptr;
l->previous = NULL;
l->next = lwts;
lwts = l;
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);
++lwt_total;
}
static void
lwt_yield ( void ) {
struct lwt *l = lwt_current;
struct lwt *n;
n = l->next;
if (NULL == n) {
n = lwts;
}
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;
}
defcmd (tcor_spawn, "tcor-spawn");
defcmd (tcor_yield, "tcor-yield");
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;
if (2 != objc) {
Tcl_WrongNumArgs (interp, 1, objv, "command-list");
return TCL_ERROR;
}
cmd = Tcl_DuplicateObj (objv[1]);
Tcl_IncrRefCount (cmd);
lwt_spawn (tcor_spawn_start, cmd);
return TCL_OK;
}
static int
tcor_yield (OBJ_CMD_ARGS) {
lwt_yield ();
return TCL_OK;
}
int Tcor_Init (Tcl_Interp *interp) {
if (NULL == Tcl_InitStubs (interp, TCL_VERSION, 0))
return TCL_ERROR;
defcmd (tcor_spawn, "tcor-spawn");
defcmd (tcor_yield, "tcor-yield");
lwt_init ();
return TCL_OK;
}Test code
load ./tcor.so
set cmd { proc hello {} {
while 1 {
puts HELLO
tcor-yield
}} hello } proc main {} {
tcor-spawn $::cmd package require Tk puts MAIN tcor-yield vwait forever
}
main