Posted to tcl by GPS at Sun Sep 09 08:37:34 GMT 2007view raw

  1. /* Tcor by George Peter Staplin */
  2.  
  3. #include <tcl.h>
  4. #include <stdlib.h>
  5. #include <ucontext.h>
  6.  
  7. #define OBJ_CMD_ARGS ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]
  8.  
  9. #define defcmd(func,name) \
  10. Tcl_CreateObjCommand (interp, name, func, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL)
  11.  
  12. #define STACK_SIZE 8192
  13.  
  14. struct lwt {
  15. ucontext_t context;
  16. struct lwt *previous, *next;
  17. void *ptr;
  18. };
  19.  
  20. static struct lwt *lwts = NULL;
  21. static struct lwt *lwt_current = NULL;
  22. static int lwt_total = 0;
  23.  
  24. static void lwt_exit (void);
  25. static void lwt_init (void);
  26. static void lwt_spawn (void (*func) (void), void *ptr);
  27. static void lwt_yield (void);
  28. static int tcor_spawn (OBJ_CMD_ARGS);
  29. static int tcor_yield (OBJ_CMD_ARGS);
  30.  
  31. int Tcor_Init (Tcl_Interp *interp);
  32.  
  33. static void
  34. lwt_exit (void) {
  35. struct lwt *l = lwt_current;
  36. struct lwt *n;
  37.  
  38. /* delink the lwt */
  39. if (l->previous) {
  40. l->previous = l->next;
  41. if (l->next) {
  42. l->next->previous = l->previous;
  43. }
  44. } else {
  45. lwts = l->next;
  46. if (lwts) {
  47. lwts->previous = NULL;
  48. }
  49. }
  50.  
  51. free (l->context.uc_stack.ss_sp);
  52. free (l);
  53.  
  54. n = lwts;
  55. lwt_current = n;
  56.  
  57. if (setcontext (&n->context)) {
  58. perror ("lwt_exit :- setcontext");
  59. abort ();
  60. }
  61. /* NOTREACHED */
  62. }
  63.  
  64. static void
  65. lwt_init ( void ) {
  66. struct lwt *l;
  67.  
  68. l = malloc (sizeof *l);
  69. if (NULL == l) {
  70. perror ("lwt_init :- malloc");
  71. abort ();
  72. }
  73.  
  74. l->ptr = NULL;
  75. l->previous = NULL;
  76. l->next = lwts;
  77. lwts = l;
  78.  
  79. lwt_current = l;
  80. ++lwt_total;
  81.  
  82. if (getcontext (&l->context)) {
  83. perror ("lwt_init :- getcontext");
  84. abort ();
  85. }
  86.  
  87. l->context.uc_link = NULL;
  88. }
  89.  
  90.  
  91. static void
  92. lwt_spawn ( void (*func) (void), void *ptr) {
  93. struct lwt *l;
  94.  
  95. l = malloc (sizeof *l);
  96. if (NULL == l) {
  97. perror ("lwt_spawn :- malloc lwt");
  98. abort ();
  99. }
  100.  
  101. l->ptr = ptr;
  102. l->previous = NULL;
  103. l->next = lwts;
  104. lwts = l;
  105.  
  106. if (getcontext (&l->context)) {
  107. perror ("getcontext");
  108. abort ();
  109. }
  110.  
  111. l->context.uc_link = NULL;
  112. l->context.uc_stack.ss_sp = malloc (STACK_SIZE);
  113. if (NULL == l->context.uc_stack.ss_sp) {
  114. perror ("lwt_spawn :- malloc stack");
  115. abort ();
  116. }
  117. l->context.uc_stack.ss_flags = 0;
  118. l->context.uc_stack.ss_size = STACK_SIZE;
  119.  
  120. makecontext (&l->context, func, 0);
  121. ++lwt_total;
  122. }
  123.  
  124. static void
  125. lwt_yield ( void ) {
  126. struct lwt *l = lwt_current;
  127. struct lwt *n;
  128.  
  129. n = l->next;
  130. if (NULL == n) {
  131. n = lwts;
  132. }
  133.  
  134. lwt_current = n;
  135.  
  136. if (l == n) {
  137. /* There is only 1 lwt that exists. */
  138. if (getcontext (&l->context)) {
  139. perror ("lwt_yield :- getcontext");
  140. abort ();
  141. }
  142. return;
  143. }
  144.  
  145. if (swapcontext (&l->context, &n->context)) {
  146. perror ("lwt_yield :- swapcontext");
  147. abort ();
  148. }
  149. /* NOTREACHED */
  150. }
  151.  
  152. static void
  153. tcor_spawn_start (void) {
  154. Tcl_Obj *cmd = lwt_current->ptr;
  155. Tcl_Interp *interp;
  156.  
  157. interp = Tcl_CreateInterp ();
  158. defcmd (tcor_spawn, "tcor-spawn");
  159. defcmd (tcor_yield, "tcor-yield");
  160.  
  161. if (TCL_ERROR == Tcl_EvalObjEx (interp, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT)) {
  162. fprintf (stderr, "spawned task evaluation error: %s\n", Tcl_GetStringResult (interp));
  163. }
  164. Tcl_DecrRefCount (cmd);
  165. Tcl_DeleteInterp (interp);
  166. lwt_exit ();
  167. }
  168.  
  169. static int
  170. tcor_spawn (OBJ_CMD_ARGS) {
  171. Tcl_Obj *cmd;
  172.  
  173. if (2 != objc) {
  174. Tcl_WrongNumArgs (interp, 1, objv, "command-list");
  175. return TCL_ERROR;
  176. }
  177.  
  178. cmd = Tcl_DuplicateObj (objv[1]);
  179. Tcl_IncrRefCount (cmd);
  180. lwt_spawn (tcor_spawn_start, cmd);
  181.  
  182. return TCL_OK;
  183. }
  184.  
  185. static int
  186. tcor_yield (OBJ_CMD_ARGS) {
  187. lwt_yield ();
  188. return TCL_OK;
  189. }
  190.  
  191. int Tcor_Init (Tcl_Interp *interp) {
  192. if (NULL == Tcl_InitStubs (interp, TCL_VERSION, 0))
  193. return TCL_ERROR;
  194.  
  195. defcmd (tcor_spawn, "tcor-spawn");
  196. defcmd (tcor_yield, "tcor-yield");
  197.  
  198. lwt_init ();
  199.  
  200. return TCL_OK;
  201. }