tcor - Tcl experiment with ucontext

/* 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 8192

struct lwt {
 ucontext_t context;
 struct lwt *previous, *next;
 void *ptr;
};

static struct lwt *lwts = NULL;
static struct lwt *lwt_current = NULL;
static int lwt_total = 0;

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_exit (void) {
 struct lwt *l = lwt_current;
 struct lwt *n;

 /* 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; 
  }
 }

 free (l->context.uc_stack.ss_sp);
 free (l);

 n = lwts;
 lwt_current = n;

 if (setcontext (&n->context)) {
  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;
}


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 1 lwt that exists. */
  if (getcontext (&l->context)) {
   perror ("lwt_yield :- getcontext"); 
   abort ();
  }
  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 ();
 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));
 }
 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;
}