thread.c 10.3 KB
Newer Older
eg's avatar
eg committed
1
/*
eg's avatar
eg committed
2
 * thread.c			-- Threads support in STklos
eg's avatar
eg committed
3
 * 
Erick Gallesio's avatar
.  
Erick Gallesio committed
4
 * Copyright  2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
eg's avatar
eg committed
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
 * 
 * 
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 * 
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 
 * USA.
 * 
 *           Author: Erick Gallesio [eg@essi.fr]
 *    Creation date: 23-Jan-2006 12:14 (eg)
24
 * Last file update: 15-Apr-2006 13:06 (eg)
eg's avatar
eg committed
25 26
 */

eg's avatar
eg committed
27 28

#include <unistd.h>
eg's avatar
eg committed
29 30
#include "stklos.h"
#include "vm.h"
31
#include "thread.h"
eg's avatar
eg committed
32

33
SCM STk_primordial_thread = NULL;
34
static SCM cond_thread_terminated, cond_join_timeout, cond_thread_abandonned_mutex;
eg's avatar
eg committed
35 36 37
static SCM all_threads = STk_nil;


eg's avatar
eg committed
38 39 40 41 42 43
static void error_bad_thread(SCM obj)
{
  STk_error("bad thread ~S", obj);
}


eg's avatar
eg committed
44 45 46 47 48 49
/*
 * Thread specific value (the VM)
 */
static pthread_key_t vm_key;

static void *cleanup_vm_specific(void *p)    /* Nothing to do for now */
eg's avatar
eg committed
50
{
eg's avatar
eg committed
51 52
  return NULL;
}
eg's avatar
eg committed
53

eg's avatar
eg committed
54 55 56 57 58 59 60 61
static void initialize_vm_key(void)
{
  int n =  pthread_key_create(&vm_key, (void (*) (void *)) cleanup_vm_specific);

  if (n) {
    fprintf(stderr, "Cannot initialize the VM specific data\n");
    perror("stklos");
    exit(1);
eg's avatar
eg committed
62
  }
eg's avatar
eg committed
63 64 65 66 67 68 69 70
}

vm_thread_t *STk_get_current_vm(void)
{
  return (vm_thread_t *) pthread_getspecific(vm_key);
}


eg's avatar
eg committed
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89
/* ====================================================================== */

static void terminate_scheme_thread(void *arg)
{
  SCM thr = (SCM) arg;

  pthread_mutex_lock(&THREAD_MYMUTEX(thr));
  THREAD_STATE(thr)  = th_terminated;

  /* signal the death of this thread to the ones waiting it */
  pthread_cond_broadcast(&THREAD_MYCONDV(thr));
  pthread_mutex_unlock(&THREAD_MYMUTEX(thr));
}


static void *start_scheme_thread(void *arg)
{
  volatile SCM thr = (SCM) arg;
  SCM res;
90 91
  
  pthread_setspecific(vm_key, THREAD_VM(thr));
eg's avatar
eg committed
92 93 94 95 96 97 98 99 100 101 102 103
  pthread_cleanup_push(terminate_scheme_thread, thr);
  
  res = STk_C_apply(THREAD_THUNK(thr), 0);
  if (THREAD_EXCEPTION(thr) == STk_false) {
    THREAD_RESULT(thr) = res;
  }
  pthread_cleanup_pop(1);
  return NULL;
}



eg's avatar
eg committed
104 105 106 107 108
/* ====================================================================== */

static SCM do_make_thread(SCM thunk, char *name)
{
  SCM z;
eg's avatar
eg committed
109 110 111

  NEWCELL(z, thread);
  
eg's avatar
eg committed
112
  THREAD_THUNK(z)     = thunk;
eg's avatar
eg committed
113 114 115 116
  THREAD_NAME(z)      = name;
  THREAD_SPECIFIC(z)  = STk_void;
  THREAD_RESULT(z)    = STk_void;
  THREAD_EXCEPTION(z) = STk_false;
eg's avatar
eg committed
117
  THREAD_STATE(z)     = th_new;
118
  THREAD_VM(z)        = NULL;
Erick Gallesio's avatar
.  
Erick Gallesio committed
119
  
eg's avatar
eg committed
120
  // FIX: lock
121
  all_threads = STk_cons(z, all_threads); /* For the GC */
eg's avatar
eg committed
122 123 124 125 126 127 128 129 130
  return z;
}

DEFINE_PRIMITIVE("current-thread", current_thread, subr0, (void))
{
  vm_thread_t *vm = STk_get_current_vm();
  return vm->scheme_thread;
}

eg's avatar
eg committed
131
DEFINE_PRIMITIVE("%make-thread", make_thread, subr12, (SCM thunk, SCM name))
eg's avatar
eg committed
132 133 134 135 136 137 138 139 140 141 142 143
{
  SCM z;

  if (STk_procedurep(thunk) == STk_false) 
    STk_error("bad thunk ~S", thunk);
  if (name) {
    if (!STRINGP(name))
      STk_error("bad thread name ~S", name);
  }
  else name = STk_Cstring2string("");

  z = do_make_thread(thunk, name);
eg's avatar
eg committed
144 145 146 147 148 149 150 151 152 153 154 155 156 157 158
  return z;
}


DEFINE_PRIMITIVE("thread?", threadp, subr1, (SCM obj))
{
  return MAKE_BOOLEAN(THREADP(obj));
}

DEFINE_PRIMITIVE("thread-name", thread_name, subr1, (SCM thr))
{
  if (! THREADP(thr)) error_bad_thread(thr);
  return THREAD_NAME(thr);
}

eg's avatar
eg committed
159
DEFINE_PRIMITIVE("%thread-end-exception", thread_end_exception, subr1, (SCM thr))
eg's avatar
eg committed
160
{
eg's avatar
eg committed
161 162
  if (!THREADP(thr)) error_bad_thread(thr);
  return THREAD_EXCEPTION(thr);
eg's avatar
eg committed
163 164
}

eg's avatar
eg committed
165 166
DEFINE_PRIMITIVE("%thread-end-exception-set!", thread_end_exception_set, 
		 subr2, (SCM thr, SCM val))
eg's avatar
eg committed
167 168
{
  if (!THREADP(thr)) error_bad_thread(thr);
eg's avatar
eg committed
169
  THREAD_EXCEPTION(thr) = val;
eg's avatar
eg committed
170 171 172
  return STk_void;
}

eg's avatar
eg committed
173 174 175 176 177
DEFINE_PRIMITIVE("%thread-end-result", thread_end_result, subr1, (SCM thr))
{
  if (!THREADP(thr)) error_bad_thread(thr);
  return THREAD_RESULT(thr);
}
eg's avatar
eg committed
178

eg's avatar
eg committed
179 180
DEFINE_PRIMITIVE("%thread-end-result-set!", thread_end_result_set, 
		 subr2, (SCM thr, SCM val))
eg's avatar
eg committed
181
{
eg's avatar
eg committed
182 183 184
  if (!THREADP(thr)) error_bad_thread(thr);
  THREAD_RESULT(thr) = val;
  return STk_void;
eg's avatar
eg committed
185 186 187
}


eg's avatar
eg committed
188 189 190 191 192
DEFINE_PRIMITIVE("thread-specific", thread_specific, subr1, (SCM thr))
{
  if (! THREADP(thr)) error_bad_thread(thr);
  return THREAD_SPECIFIC(thr);
}
eg's avatar
eg committed
193

eg's avatar
eg committed
194 195
DEFINE_PRIMITIVE("thread-specific-set!", thread_specific_set, subr2, 
		 (SCM thr, SCM value))
eg's avatar
eg committed
196
{
eg's avatar
eg committed
197 198 199 200
  if (!THREADP(thr)) error_bad_thread(thr);
  THREAD_SPECIFIC(thr) = value;
  return STk_void;
}
eg's avatar
eg committed
201 202


eg's avatar
eg committed
203 204


eg's avatar
eg committed
205
DEFINE_PRIMITIVE("thread-start!", thread_start, subr1, (SCM thr))
eg's avatar
eg committed
206
{
eg's avatar
eg committed
207
  pthread_attr_t attr;
208 209
  vm_thread_t *vm, *new;

eg's avatar
eg committed
210
  if (!THREADP(thr)) error_bad_thread(thr);
eg's avatar
eg committed
211 212 213
  if (THREAD_STATE(thr) != th_new) 
    STk_error("thread has already been started ~S", thr);

214 215 216 217 218 219 220 221 222 223
  vm  = STk_get_current_vm();
  new = STk_allocate_vm(5000);			// FIX:

  new->current_module = vm->current_module;
  new->iport          = vm->iport;
  new->oport          = vm->oport;
  new->eport          = vm->eport;
  new->parameters     = STk_copy_tree(vm->parameters);
  new->scheme_thread  = thr;
  
separdau's avatar
separdau committed
224
  THREAD_VM(thr)      = new; 
225
  THREAD_STATE(thr)   = th_runnable;  
eg's avatar
eg committed
226

eg's avatar
eg committed
227 228 229 230 231 232 233
  pthread_attr_init(&attr);
  pthread_attr_setdetachstate(&attr, TRUE);
  pthread_mutex_init(&THREAD_MYMUTEX(thr), NULL);
  pthread_cond_init(&THREAD_MYCONDV(thr), NULL);

  // pthread_mutex_lock(&THREAD_MYMUTEX(thr));

eg's avatar
eg committed
234
  if (pthread_create(&THREAD_PTHREAD(thr), NULL, start_scheme_thread, thr))
eg's avatar
eg committed
235
    STk_error("cannot start thread ~S", thr);
eg's avatar
eg committed
236

eg's avatar
eg committed
237 238
  pthread_attr_destroy(&attr);

eg's avatar
eg committed
239 240 241 242
  return thr;
}


eg's avatar
eg committed
243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259

DEFINE_PRIMITIVE("thread-yield!", thread_yield, subr0, (void))
{
#ifdef _POSIX_PRIORITY_SCHEDULING
  sched_yield();
#else
  /* Do nothing. Is it correct? */
#endif
  return STk_void;
}

DEFINE_PRIMITIVE("thread-terminate!", thread_terminate, subr1, (SCM thr))
{
  if (!THREADP(thr)) error_bad_thread(thr);

  if (THREAD_STATE(thr) != th_terminated) {
    terminate_scheme_thread(thr);
260 261 262 263 264

    pthread_mutex_lock(&THREAD_MYMUTEX(thr));
    if (THREAD_EXCEPTION(thr) == STk_void) {
      /* Be sure to register the first canceller only!  */
      THREAD_EXCEPTION(thr) = STk_make_C_cond(cond_thread_terminated, 1, thr);
eg's avatar
eg committed
265
    }
266 267 268 269 270 271 272 273
    pthread_mutex_lock(&THREAD_MYMUTEX(thr));
    
    /* Terminate effectively the thread */
    if (thr == THREAD_VM(thr)->scheme_thread)
      pthread_exit(0); 				/* Suicide */
    else 
      pthread_cancel(THREAD_PTHREAD(thr));	/* terminate an other thread */

eg's avatar
eg committed
274 275 276 277 278 279
    pthread_cancel(THREAD_PTHREAD(thr));
  }
  return STk_void;
}


280
DEFINE_PRIMITIVE("%thread-join!", thread_join, subr2, (SCM thr, SCM tm))
eg's avatar
eg committed
281
{
eg's avatar
eg committed
282 283
  struct timespec ts;
  SCM res = STk_false;
284
  double tmd;
eg's avatar
eg committed
285 286 287

  if (!THREADP(thr)) error_bad_thread(thr);

288 289 290 291 292 293 294 295
  if (REALP(tm)) {
    tmd = REAL_VAL(tm);
    ts.tv_sec  = (time_t) tmd;
    ts.tv_nsec = (suseconds_t) ((tmd - ts.tv_sec) * 1000000);
  } 
  else if (!BOOLEANP(tm))
    STk_error("bad timeout ~S", tm);
  
eg's avatar
eg committed
296 297
  pthread_mutex_lock(&THREAD_MYMUTEX(thr));
  while (THREAD_STATE(thr) != th_terminated) {
298
    if (tm != STk_false) {
eg's avatar
eg committed
299 300 301
      int n = pthread_cond_timedwait(&THREAD_MYCONDV(thr), 
				     &THREAD_MYMUTEX(thr),
				     &ts);
Erick Gallesio's avatar
Erick Gallesio committed
302
      if (n == ETIMEDOUT) { res = STk_true; break; }
eg's avatar
eg committed
303 304 305 306 307 308
    }
    else 
      pthread_cond_wait(&THREAD_MYCONDV(thr), &THREAD_MYMUTEX(thr));
  }
  pthread_mutex_unlock(&THREAD_MYMUTEX(thr));
  return res;
eg's avatar
eg committed
309 310
}

separdau's avatar
separdau committed
311 312 313 314 315 316 317 318 319 320 321 322 323
DEFINE_PRIMITIVE("%thread-sleep!", thread_sleep, subr1, (SCM tm))
{

  if (REALP(tm)){
    long n = (1000 * REAL_VAL(tm));

    // call sleep
    STk_sleep(MAKE_INT(n));
  }else
    STk_error("bad timeout ~S", tm);

  return STk_void;
}
eg's avatar
eg committed
324 325


Erick Gallesio's avatar
.  
Erick Gallesio committed
326 327 328 329
DEFINE_PRIMITIVE("%thread-system", thread_system, subr0, (void))
{
  return STk_intern("pthread");
}
eg's avatar
eg committed
330

eg's avatar
eg committed
331 332 333 334 335 336 337
/* ======================================================================
 * 	Initialization ...
 * ====================================================================== 
 */

static void print_thread(SCM thread, SCM port, int mode)
{
eg's avatar
eg committed
338
  char *s, *name = STRING_CHARS(THREAD_NAME(thread));
eg's avatar
eg committed
339 340 341 342 343 344
  
  STk_puts("#[thread ", port);
  if (*name) 
    STk_puts(name, port);
  else
    STk_fprintf(port, "%lx", (unsigned long) thread);
eg's avatar
eg committed
345 346 347 348 349 350 351 352
  switch (THREAD_STATE(thread)) {
    case th_new:        s = "new"; break;
    case th_runnable:   s = "runnable"; break;
    case th_terminated: s = "terminated"; break;
    case th_blocked:    s = "blocked"; break;
    default:            s = "???"; break;
  }
  STk_fprintf(port, " (%s)", s);
eg's avatar
eg committed
353 354 355 356 357 358 359 360 361 362 363
  STk_putc(']', port);
}


/* The stucture which describes the thread type */
static struct extended_type_descr xtype_thread = {
  "thread",			/* name */
  print_thread			/* print function */
};


eg's avatar
eg committed
364
int STk_init_threads(int stack_size)
eg's avatar
eg committed
365
{
eg's avatar
eg committed
366
  vm_thread_t *vm = STk_allocate_vm(stack_size);
367
  SCM primordial;
eg's avatar
eg committed
368

eg's avatar
eg committed
369 370
  /* Thread Type declaration */
  DEFINE_XTYPE(thread, &xtype_thread);
eg's avatar
eg committed
371 372
  
  /* Define the key to access the thead specific VM */ 
eg's avatar
eg committed
373 374
  initialize_vm_key();
  pthread_setspecific(vm_key, vm);
eg's avatar
eg committed
375 376

  /* Define the threads exceptions */
eg's avatar
eg committed
377
  cond_thread_terminated =  STk_defcond_type("&thread-terminated", STk_false,
378
					     LIST1(STk_intern("canceller")),
379
					     STk_STklos_module);
380 381 382
  cond_thread_abandonned_mutex =  STk_defcond_type("&thread-abandonned-mutex", 
						   STk_false,
						   STk_nil,
383
						   STk_STklos_module);
384
  cond_join_timeout = STk_defcond_type("&thead-join-timeout", STk_false,
385
				       STk_nil, STk_STklos_module);
eg's avatar
eg committed
386 387 388 389 390 391
  
  /* Wrap the main thread in a thread called "primordial" */
  primordial = do_make_thread(STk_false, STk_Cstring2string("primordial"));
  THREAD_STATE(primordial) = th_runnable;
  THREAD_VM(primordial)    = vm;
  vm->scheme_thread        = primordial;
392
  STk_primordial_thread	   = primordial;
eg's avatar
eg committed
393

eg's avatar
eg committed
394
  /* Thread primitives */
eg's avatar
eg committed
395
  ADD_PRIMITIVE(current_thread);
eg's avatar
eg committed
396 397 398
  ADD_PRIMITIVE(make_thread);
  ADD_PRIMITIVE(threadp);
  ADD_PRIMITIVE(thread_name);
eg's avatar
eg committed
399 400 401 402
  ADD_PRIMITIVE(thread_end_exception);
  ADD_PRIMITIVE(thread_end_exception_set);
  ADD_PRIMITIVE(thread_end_result);
  ADD_PRIMITIVE(thread_end_result_set);
eg's avatar
eg committed
403 404 405
  ADD_PRIMITIVE(thread_specific);
  ADD_PRIMITIVE(thread_specific_set);
  ADD_PRIMITIVE(thread_start);
eg's avatar
eg committed
406 407
  ADD_PRIMITIVE(thread_yield);
  ADD_PRIMITIVE(thread_terminate);
eg's avatar
eg committed
408
  ADD_PRIMITIVE(thread_join);
separdau's avatar
separdau committed
409
  ADD_PRIMITIVE(thread_sleep);
Erick Gallesio's avatar
.  
Erick Gallesio committed
410
  ADD_PRIMITIVE(thread_system);
eg's avatar
eg committed
411 412
  return TRUE;
}
eg's avatar
eg committed
413