Posted to tcl by GPS at Sun Sep 09 08:37:34 GMT 2007view raw
- /* 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;
- }