thread-common.c 10.1 KB
Newer Older
1
/*
2
 * thread-common.c                      -- Threads support in STklos
3
 *
4
 * Copyright © 2006-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
5 6
 *
 *
7 8 9
 * 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
10
 * (at your option) any later version.mu
11
 *
12 13 14 15
 * 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.
16
 *
17 18
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
19
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
20
 * USA.
21
 *
22 23
 *           Author: Erick Gallesio [eg@essi.fr]
 *    Creation date: 23-Jan-2006 12:14 (eg)
24
 * Last file update: 21-Sep-2018 09:15 (eg)
25 26 27 28 29 30 31 32 33 34 35
 */
#include <unistd.h>
#include "stklos.h"
#include "vm.h"
#include "thread-common.h"

SCM STk_primordial_thread = NULL;

SCM STk_cond_thread_terminated;
static SCM cond_thread_abandonned_mutex, cond_join_timeout;

Erick Gallesio's avatar
.  
Erick Gallesio committed
36

37
void STk_error_bad_thread(SCM obj)
38 39 40 41
{
  STk_error("bad thread ~S", obj);
}

42 43 44 45 46 47 48
double STk_verify_timeout(SCM tm) {
  double res = STk_number2double(tm);

  if (isnan(res)) STk_error("bad timeout ~S", tm);
  return res;
}

49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73

struct timeval STk_thread_abstime_to_reltime(double abs_secs)
{
  struct timeval abs, cur, rel;

  abs.tv_sec  = (long) abs_secs; /* trim to the second */
  abs.tv_usec = (long) ((abs_secs - abs.tv_sec) * 1000000);

  /* now deduce the current time */
  gettimeofday(&cur, NULL);
  rel.tv_sec  = abs.tv_sec - cur.tv_sec;
  rel.tv_usec = abs.tv_usec - cur.tv_usec;
  if (rel.tv_usec < 0) {
    rel.tv_sec  -= 1;
    rel.tv_usec += 1000000;
  }

  /* is it negative ? */
  if (rel.tv_sec < 0) {
    rel.tv_sec = 0;
    rel.tv_usec = 0;
  }
  return rel;
}

74

eg's avatar
eg committed
75
/*
76
<doc EXT current-thread
eg's avatar
eg committed
77 78 79 80 81
 * (current-thread)
 *
 *  Returns the current thread.
 * @lisp
 * (eq? (current-thread) (current-thread))  =>  #t
82
 * @end lisp
eg's avatar
eg committed
83 84
doc>
*/
85 86 87 88 89 90
DEFINE_PRIMITIVE("current-thread", current_thread, subr0, (void))
{
  vm_thread_t *vm = STk_get_current_vm();
  return vm->scheme_thread;
}

Erick Gallesio's avatar
.  
Erick Gallesio committed
91 92 93 94 95 96
DEFINE_PRIMITIVE("%thread-dynwind-stack", thread_dynwind_stack, subr0, (void))
{
  vm_thread_t *vm = STk_get_current_vm();
  return vm->dynwind_stack;
}

97
DEFINE_PRIMITIVE("%thread-dynwind-stack-set!", thread_dynwind_stack_set, subr1,
98
                 (SCM value))
Erick Gallesio's avatar
.  
Erick Gallesio committed
99 100 101 102
{
  vm_thread_t *vm = STk_get_current_vm();
  vm->dynwind_stack = value;
  return STk_void;
103

Erick Gallesio's avatar
.  
Erick Gallesio committed
104 105 106 107 108 109
}


/* ====================================================================== */


110
static SCM do_make_thread(SCM thunk, SCM name, int stack_size)
111 112
{
  SCM z;
113

114
  NEWCELL(z, thread);
115

116 117 118 119 120 121 122 123
  THREAD_THUNK(z)      = thunk;
  THREAD_NAME(z)       = name;
  THREAD_SPECIFIC(z)   = STk_void;
  THREAD_RESULT(z)     = STk_void;
  THREAD_EXCEPTION(z)  = STk_false;
  THREAD_STATE(z)      = th_new;
  THREAD_STACK_SIZE(z) = stack_size;
  THREAD_VM(z)         = NULL;
124

125 126
  STk_do_make_sys_thread(z);

127 128 129
  return z;
}

Erick Gallesio's avatar
.  
Erick Gallesio committed
130

131
DEFINE_PRIMITIVE("%make-thread", make_thread, subr3,(SCM thunk, SCM name, SCM ssize))
132 133
{
  SCM z;
134
  int stack_size;
135

136
  if (STk_procedurep(thunk) == STk_false)
137
    STk_error("bad thunk ~S", thunk);
138
  if (ssize == STk_false)
139 140 141 142 143 144 145
    /* If no size is specified, use primordial thread stack size */
    stack_size = THREAD_STACK_SIZE(STk_primordial_thread);
  else {
    stack_size = STk_integer_value(ssize);
    if (stack_size < 0)
      STk_error("bad stack size ~S", ssize);
  }
146

147
  z = do_make_thread(thunk, (name ? name : STk_false), stack_size);
148 149 150
  return z;
}

eg's avatar
eg committed
151
/*
152
<doc EXT thread?
eg's avatar
eg committed
153
 * (thread? obj)
154
 *
eg's avatar
eg committed
155 156 157 158
 * Returns |#t| if |obj| is a thread, otherwise returns |#f|.
 * @lisp
 * (thread? (current-thread))  => #t
   (thread? 'foo)              => #f
159
 * @end lisp
eg's avatar
eg committed
160 161
doc>
*/
162 163 164 165 166
DEFINE_PRIMITIVE("thread?", threadp, subr1, (SCM obj))
{
  return MAKE_BOOLEAN(THREADP(obj));
}

eg's avatar
eg committed
167 168

/*
169
<doc EXT thread-name
eg's avatar
eg committed
170
 * (thread-name thread)
171
 *
eg's avatar
eg committed
172 173 174 175 176 177
 * Returns the name of the |thread|.
 * @lisp
 * (thread-name (make-thread (lambda () #f) 'foo))  =>  foo
 * @end lisp
doc>
*/
178 179
DEFINE_PRIMITIVE("thread-name", thread_name, subr1, (SCM thr))
{
180
  if (! THREADP(thr)) STk_error_bad_thread(thr);
181 182 183
  return THREAD_NAME(thr);
}

eg's avatar
eg committed
184
/*
185
<doc EXT thread-stack-size
eg's avatar
eg committed
186
 * (thread-stack-size thread)
187
 *
eg's avatar
eg committed
188 189 190 191 192 193 194 195 196 197
 * Returns the allocated stack size for |thread|.
 * Note that this procedure is not present in ,(quick-link-srfi 18).
doc>
*/
DEFINE_PRIMITIVE("thread-stack-size", thread_ssize, subr1, (SCM thr))
{
  if (! THREADP(thr)) STk_error_bad_thread(thr);
  return MAKE_INT(THREAD_STACK_SIZE(thr));
}

198 199
DEFINE_PRIMITIVE("%thread-end-exception", thread_end_exception, subr1, (SCM thr))
{
200
  if (!THREADP(thr)) STk_error_bad_thread(thr);
201 202 203
  return THREAD_EXCEPTION(thr);
}

204
DEFINE_PRIMITIVE("%thread-end-exception-set!", thread_end_exception_set,
205
                 subr2, (SCM thr, SCM val))
206
{
207
  if (!THREADP(thr)) STk_error_bad_thread(thr);
208 209 210 211 212 213
  THREAD_EXCEPTION(thr) = val;
  return STk_void;
}

DEFINE_PRIMITIVE("%thread-end-result", thread_end_result, subr1, (SCM thr))
{
214
  if (!THREADP(thr)) STk_error_bad_thread(thr);
215 216 217
  return THREAD_RESULT(thr);
}

218
DEFINE_PRIMITIVE("%thread-end-result-set!", thread_end_result_set,
219
                 subr2, (SCM thr, SCM val))
220
{
221
  if (!THREADP(thr)) STk_error_bad_thread(thr);
222 223 224 225
  THREAD_RESULT(thr) = val;
  return STk_void;
}

eg's avatar
eg committed
226 227 228
/*
<doc EXT thread-specific
 * (thread-specific thread)
229
 *
eg's avatar
eg committed
230 231 232
 * Returns the content of the |thread|'s specific field.
doc>
*/
233 234
DEFINE_PRIMITIVE("thread-specific", thread_specific, subr1, (SCM thr))
{
235
  if (! THREADP(thr)) STk_error_bad_thread(thr);
236 237 238
  return THREAD_SPECIFIC(thr);
}

eg's avatar
eg committed
239 240 241
/*
<doc EXT thread-specific-set!
 * (thread-specific-set! thread)
242 243
 *
 * Stores |obj| into the |thread|'s specific field. |Thread-specific-set!|
eg's avatar
eg committed
244 245
 * returns an unspecified value.
 * @lisp
246
 * (thread-specific-set! (current-thread) "hello")
eg's avatar
eg committed
247 248 249 250 251 252
 *            =>  unspecified
 * (thread-specific (current-thread))
 *            =>  "hello"
 * @end lisp
doc>
*/
253
DEFINE_PRIMITIVE("thread-specific-set!", thread_specific_set, subr2,
254
                 (SCM thr, SCM value))
255
{
256
  if (!THREADP(thr)) STk_error_bad_thread(thr);
257 258 259 260
  THREAD_SPECIFIC(thr) = value;
  return STk_void;
}

eg's avatar
eg committed
261 262 263 264

/*
<doc EXT thread-start!
 * (thread-start! thread)
265 266
 *
 * Makes |thread| runnable. The |thread| must be a new thread.
eg's avatar
eg committed
267 268
 * |Thread-start!| returns the thread.
 * @lisp
269
 * (let ((t (thread-start! (make-thread
eg's avatar
eg committed
270 271 272 273 274 275 276
 *                            (lambda () (write 'a))))))
 *    (write 'b)
 *    (thread-join! t))       =>  unspecified
 *                                after writing ab or ba
 * @end lisp
doc>
*/
277 278 279
DEFINE_PRIMITIVE("thread-start!", thread_start, subr1, (SCM thr))
{
  vm_thread_t *vm, *new;
280

281
  if (!THREADP(thr)) STk_error_bad_thread(thr);
282
  if (THREAD_STATE(thr) != th_new)
283 284 285
    STk_error("thread has already been started ~S", thr);

  vm  = STk_get_current_vm();
286
  new = STk_allocate_vm(THREAD_STACK_SIZE(thr));
287 288 289 290 291 292

  new->current_module = vm->current_module;
  new->iport          = vm->iport;
  new->oport          = vm->oport;
  new->eport          = vm->eport;
  new->scheme_thread  = thr;
293 294 295

  THREAD_VM(thr)      = new;
  THREAD_STATE(thr)   = th_runnable;
296

297
  STk_sys_thread_start(thr);
298

299 300 301 302
  return thr;
}

/* ======================================================================
303
 *      Initialization ...
304
 * ======================================================================
305 306 307 308 309 310
 */

static void print_thread(SCM thread, SCM port, int mode)
{
  char *s;
  SCM name = THREAD_NAME(thread);
311

312
  STk_puts("#[thread ", port);
313
  if (name != STk_false)
314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330
    STk_print(name, port, DSP_MODE);
  else
    STk_fprintf(port, "%lx", (unsigned long) thread);
  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);
  STk_putc(']', port);
}


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

Erick Gallesio's avatar
.  
Erick Gallesio committed
335 336
/* ---------------------------------------------------------------------- */

337
int STk_init_threads(int stack_size, void *start_stack)
338 339 340 341 342 343
{
  vm_thread_t *vm = STk_allocate_vm(stack_size);
  SCM primordial;

  /* Thread Type declaration */
  DEFINE_XTYPE(thread, &xtype_thread);
Erick Gallesio's avatar
.  
Erick Gallesio committed
344

345
  /* Specific thread initialisation */
Erick Gallesio's avatar
.  
Erick Gallesio committed
346
  if (STk_init_sys_threads(vm) != TRUE)
347 348 349 350 351 352 353
    return FALSE;

  /* Define the threads exceptions */
  STk_cond_thread_terminated =
    STk_defcond_type("&thread-terminated", STk_false,
                     LIST1(STk_intern("canceller")),
                     STk_STklos_module);
354
  cond_thread_abandonned_mutex =  STk_defcond_type("&thread-abandonned-mutex",
355 356 357 358 359 360 361
                                                   STk_false,
                                                   STk_nil,
                                                   STk_STklos_module);
  cond_join_timeout = STk_defcond_type("&thread-join-timeout", STk_false,
                                       STk_nil, STk_STklos_module);

  /* Wrap the main thread in a thread called "primordial" */
362
  primordial = do_make_thread(STk_false,
363 364
                              STk_Cstring2string("primordial"),
                              stack_size);
365 366 367
  THREAD_STATE(primordial) = th_runnable;
  THREAD_VM(primordial)    = vm;
  vm->scheme_thread        = primordial;
368
  vm->start_stack          = start_stack;
369 370 371 372
  STk_primordial_thread    = primordial;

  /* Thread primitives */
  ADD_PRIMITIVE(current_thread);
Erick Gallesio's avatar
.  
Erick Gallesio committed
373 374
  ADD_PRIMITIVE(thread_dynwind_stack);
  ADD_PRIMITIVE(thread_dynwind_stack_set);
375 376 377
  ADD_PRIMITIVE(make_thread);
  ADD_PRIMITIVE(threadp);
  ADD_PRIMITIVE(thread_name);
eg's avatar
eg committed
378
  ADD_PRIMITIVE(thread_ssize);
379 380 381 382 383 384 385 386 387 388 389 390 391 392 393
  ADD_PRIMITIVE(thread_end_exception);
  ADD_PRIMITIVE(thread_end_exception_set);
  ADD_PRIMITIVE(thread_end_result);
  ADD_PRIMITIVE(thread_end_result_set);
  ADD_PRIMITIVE(thread_specific);
  ADD_PRIMITIVE(thread_specific_set);
  ADD_PRIMITIVE(thread_start);
  ADD_PRIMITIVE(thread_yield);
  ADD_PRIMITIVE(thread_terminate);
  ADD_PRIMITIVE(thread_join);
  ADD_PRIMITIVE(thread_sleep);
  ADD_PRIMITIVE(thread_system);

  return TRUE;
}