118 |
} scm_copt_thread; |
} scm_copt_thread; |
119 |
|
|
120 |
static SCM |
static SCM |
121 |
make_thread (SCM args) |
make_thread (SCM creation_protects) |
122 |
{ |
{ |
123 |
SCM z; |
SCM z; |
124 |
scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread"); |
scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread"); |
125 |
z = scm_cell (scm_tc16_thread, (scm_t_bits)t); |
z = scm_cell (scm_tc16_thread, (scm_t_bits)t); |
126 |
t->handle = z; |
t->handle = z; |
127 |
t->result = args; |
t->result = creation_protects; |
128 |
t->base = NULL; |
t->base = NULL; |
129 |
t->joining_threads = make_queue (); |
t->joining_threads = make_queue (); |
130 |
pthread_cond_init (&t->sleep_cond, NULL); |
pthread_cond_init (&t->sleep_cond, NULL); |
154 |
thread_mark (SCM obj) |
thread_mark (SCM obj) |
155 |
{ |
{ |
156 |
scm_copt_thread *t = SCM_THREAD_DATA (obj); |
scm_copt_thread *t = SCM_THREAD_DATA (obj); |
|
#ifdef DEBUG |
|
|
// fprintf (stderr, "marking %ld\n", t->pthread); |
|
|
#endif |
|
157 |
scm_gc_mark (t->result); |
scm_gc_mark (t->result); |
158 |
scm_gc_mark (t->joining_threads); |
scm_gc_mark (t->joining_threads); |
159 |
return t->root->handle; |
return t->root->handle; |
180 |
thread_free (SCM obj) |
thread_free (SCM obj) |
181 |
{ |
{ |
182 |
scm_copt_thread *t = SCM_THREAD_DATA (obj); |
scm_copt_thread *t = SCM_THREAD_DATA (obj); |
|
#ifdef DEBUG |
|
|
// fprintf (stderr, "freeing %ld\n", t->pthread); |
|
|
#endif |
|
183 |
if (t->pthread != -1) |
if (t->pthread != -1) |
184 |
abort (); |
abort (); |
185 |
scm_gc_free (t, sizeof (*t), "thread"); |
scm_gc_free (t, sizeof (*t), "thread"); |
408 |
SCM |
SCM |
409 |
scm_yield () |
scm_yield () |
410 |
{ |
{ |
411 |
/* Testing guile_mutex.next_waiting is safe since only the owner of |
/* Testing guile_mutex.next_waiting without locking guile_mutex.lock |
412 |
guile_mutex can bring it from non-NULL to NULL. We are the |
is OK since the outcome is not critical. Even when it changes |
413 |
owner, so that can not happen. When it goes from NULL to |
after the test, we do the right thing. |
|
non-NULL, we might miss it this time, but next time we will |
|
|
yield. |
|
414 |
*/ |
*/ |
415 |
if (guile_mutex.next_waiting) |
if (guile_mutex.next_waiting) |
416 |
{ |
{ |
458 |
static SCM all_threads; |
static SCM all_threads; |
459 |
static int thread_count; |
static int thread_count; |
460 |
|
|
461 |
typedef struct scheme_launch_data { |
typedef struct launch_data { |
462 |
|
SCM thread; |
463 |
SCM rootcont; |
SCM rootcont; |
464 |
SCM body; |
scm_t_catch_body body; |
465 |
SCM handler; |
void *body_data; |
466 |
} scheme_launch_data; |
scm_t_catch_handler handler; |
467 |
|
void *handler_data; |
468 |
|
} launch_data; |
469 |
|
|
470 |
static SCM |
static SCM |
471 |
scheme_body_bootstrip (scheme_launch_data* data) |
body_bootstrip (launch_data* data) |
472 |
{ |
{ |
473 |
/* First save the new root continuation */ |
/* First save the new root continuation */ |
474 |
data->rootcont = scm_root->rootcont; |
data->rootcont = scm_root->rootcont; |
475 |
return scm_call_0 (data->body); |
return (data->body) (data->body_data); |
476 |
|
// return scm_call_0 (data->body); |
477 |
} |
} |
478 |
|
|
479 |
static SCM |
static SCM |
480 |
scheme_handler_bootstrip (scheme_launch_data* data, SCM tag, SCM throw_args) |
handler_bootstrip (launch_data* data, SCM tag, SCM throw_args) |
481 |
{ |
{ |
482 |
scm_root->rootcont = data->rootcont; |
scm_root->rootcont = data->rootcont; |
483 |
return scm_apply_1 (data->handler, tag, throw_args); |
return (data->handler) (data->handler_data, tag, throw_args); |
484 |
|
// return scm_apply_1 (data->handler, tag, throw_args); |
485 |
} |
} |
486 |
|
|
487 |
static void |
static void |
488 |
really_launch (SCM_STACKITEM *base, SCM thread) |
really_launch (SCM_STACKITEM *base, launch_data *data) |
489 |
{ |
{ |
490 |
|
SCM thread = data->thread; |
491 |
scm_copt_thread *t = SCM_THREAD_DATA (thread); |
scm_copt_thread *t = SCM_THREAD_DATA (thread); |
|
scheme_launch_data data; |
|
492 |
init_thread_creatant (thread, base); |
init_thread_creatant (thread, base); |
493 |
enter_guile (t); |
enter_guile (t); |
494 |
|
|
495 |
data.rootcont = SCM_BOOL_F; |
data->rootcont = SCM_BOOL_F; |
|
data.body = SCM_CAR (t->result); |
|
|
data.handler = SCM_CADR (t->result); |
|
496 |
t->result = |
t->result = |
497 |
scm_internal_cwdr ((scm_t_catch_body) scheme_body_bootstrip, |
scm_internal_cwdr ((scm_t_catch_body) body_bootstrip, |
498 |
&data, |
data, |
499 |
(scm_t_catch_handler) scheme_handler_bootstrip, |
(scm_t_catch_handler) handler_bootstrip, |
500 |
&data, base); |
data, base); |
501 |
|
free (data); |
502 |
|
|
503 |
pthread_detach (t->pthread); |
pthread_detach (t->pthread); |
504 |
all_threads = scm_delq (thread, all_threads); |
all_threads = scm_delq (thread, all_threads); |
508 |
} |
} |
509 |
|
|
510 |
static void * |
static void * |
511 |
scheme_launch_thread (void *p) |
launch_thread (void *p) |
512 |
{ |
{ |
513 |
really_launch ((SCM_STACKITEM *)&p, (SCM)p); |
really_launch ((SCM_STACKITEM *)&p, (launch_data *)p); |
514 |
return NULL; |
return NULL; |
515 |
} |
} |
516 |
|
|
517 |
SCM |
static SCM |
518 |
scm_call_with_new_thread (SCM argl) |
create_thread (scm_t_catch_body body, void *body_data, |
519 |
#define FUNC_NAME s_call_with_new_thread |
scm_t_catch_handler handler, void *handler_data, |
520 |
|
SCM protects) |
521 |
{ |
{ |
522 |
SCM thread; |
SCM thread; |
523 |
|
|
|
/* Check arguments. */ |
|
|
{ |
|
|
register SCM args = argl; |
|
|
SCM thunk, handler; |
|
|
if (!SCM_CONSP (args)) |
|
|
SCM_WRONG_NUM_ARGS (); |
|
|
thunk = SCM_CAR (args); |
|
|
SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), |
|
|
thunk, |
|
|
SCM_ARG1, |
|
|
s_call_with_new_thread); |
|
|
args = SCM_CDR (args); |
|
|
if (!SCM_CONSP (args)) |
|
|
SCM_WRONG_NUM_ARGS (); |
|
|
handler = SCM_CAR (args); |
|
|
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)), |
|
|
handler, |
|
|
SCM_ARG2, |
|
|
s_call_with_new_thread); |
|
|
if (!SCM_NULLP (SCM_CDR (args))) |
|
|
SCM_WRONG_NUM_ARGS (); |
|
|
} |
|
|
|
|
524 |
/* Make new thread. The first thing the new thread will do is to |
/* Make new thread. The first thing the new thread will do is to |
525 |
lock guile_mutex. Thus, we can safely complete its |
lock guile_mutex. Thus, we can safely complete its |
526 |
initialization after creating it. While the new thread starts, |
initialization after creating it. While the new thread starts, |
530 |
{ |
{ |
531 |
pthread_t th; |
pthread_t th; |
532 |
SCM root, old_winds; |
SCM root, old_winds; |
533 |
|
launch_data *data; |
534 |
|
|
535 |
/* Unwind wind chain. */ |
/* Unwind wind chain. */ |
536 |
old_winds = scm_dynwinds; |
old_winds = scm_dynwinds; |
537 |
scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds)); |
scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds)); |
538 |
|
|
539 |
/* Allocate thread locals. */ |
/* Allocate thread locals. */ |
540 |
root = scm_make_root (scm_root->handle); |
root = scm_make_root (scm_root->handle); |
541 |
|
data = scm_malloc (sizeof (launch_data)); |
542 |
|
|
543 |
/* Make thread. */ |
/* Make thread. */ |
544 |
thread = make_thread (argl); |
thread = make_thread (protects); |
545 |
pthread_create (&th, NULL, scheme_launch_thread, (void *) thread); |
data->thread = thread; |
546 |
|
data->body = body; |
547 |
|
data->body_data = body_data; |
548 |
|
data->handler = handler; |
549 |
|
data->handler_data = handler_data; |
550 |
|
pthread_create (&th, NULL, launch_thread, (void *) data); |
551 |
init_thread_creator (thread, th, SCM_ROOT_STATE (root)); |
init_thread_creator (thread, th, SCM_ROOT_STATE (root)); |
552 |
all_threads = scm_cons (thread, all_threads); |
all_threads = scm_cons (thread, all_threads); |
553 |
thread_count++; |
thread_count++; |
558 |
|
|
559 |
return thread; |
return thread; |
560 |
} |
} |
561 |
|
|
562 |
|
SCM |
563 |
|
scm_call_with_new_thread (SCM argl) |
564 |
|
#define FUNC_NAME s_call_with_new_thread |
565 |
|
{ |
566 |
|
SCM thunk, handler; |
567 |
|
|
568 |
|
/* Check arguments. */ |
569 |
|
{ |
570 |
|
register SCM args = argl; |
571 |
|
if (!SCM_CONSP (args)) |
572 |
|
SCM_WRONG_NUM_ARGS (); |
573 |
|
thunk = SCM_CAR (args); |
574 |
|
SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), |
575 |
|
thunk, |
576 |
|
SCM_ARG1, |
577 |
|
s_call_with_new_thread); |
578 |
|
args = SCM_CDR (args); |
579 |
|
if (!SCM_CONSP (args)) |
580 |
|
SCM_WRONG_NUM_ARGS (); |
581 |
|
handler = SCM_CAR (args); |
582 |
|
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)), |
583 |
|
handler, |
584 |
|
SCM_ARG2, |
585 |
|
s_call_with_new_thread); |
586 |
|
if (!SCM_NULLP (SCM_CDR (args))) |
587 |
|
SCM_WRONG_NUM_ARGS (); |
588 |
|
} |
589 |
|
|
590 |
|
return create_thread ((scm_t_catch_body) scm_call_0, thunk, |
591 |
|
(scm_t_catch_handler) scm_apply_1, handler, |
592 |
|
argl); |
593 |
|
} |
594 |
#undef FUNC_NAME |
#undef FUNC_NAME |
595 |
|
|
596 |
|
SCM |
597 |
|
scm_spawn_thread (scm_t_catch_body body, void *body_data, |
598 |
|
scm_t_catch_handler handler, void *handler_data) |
599 |
|
{ |
600 |
|
return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F); |
601 |
|
} |
602 |
|
|
603 |
/*** Mutexes */ |
/*** Mutexes */ |
604 |
|
|
605 |
/* We implement our own mutex type since we want them to be 'fair', we |
/* We implement our own mutex type since we want them to be 'fair', we |
1055 |
} |
} |
1056 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1057 |
|
|
|
|
|
|
/* XXX from here to end */ |
|
|
|
|
|
#if 0 |
|
|
/* NOTE: There are TWO mechanisms for starting a thread: The first one |
|
|
is used when spawning a thread from Scheme, while the second one is |
|
|
used from C. |
|
|
|
|
|
It might be argued that the first should be implemented in terms of |
|
|
the second. The reason it isn't is that that would require an |
|
|
extra unnecessary malloc (the thread_args structure). By providing |
|
|
one pair of extra functions (c_launch_thread, scm_spawn_thread) the |
|
|
Scheme threads are started more efficiently. */ |
|
|
|
|
|
/* This is the first thread spawning mechanism: threads from Scheme */ |
|
|
|
|
|
|
|
|
|
|
|
/* This is the second thread spawning mechanism: threads from C */ |
|
|
|
|
|
typedef struct c_launch_data { |
|
|
union { |
|
|
SCM thread; |
|
|
SCM rootcont; |
|
|
} u; |
|
|
scm_t_catch_body body; |
|
|
void *body_data; |
|
|
scm_t_catch_handler handler; |
|
|
void *handler_data; |
|
|
} c_launch_data; |
|
|
|
|
|
static SCM |
|
|
c_body_bootstrip (c_launch_data* data) |
|
|
{ |
|
|
/* First save the new root continuation */ |
|
|
data->u.rootcont = scm_root->rootcont; |
|
|
return (data->body) (data->body_data); |
|
|
} |
|
|
|
|
|
static SCM |
|
|
c_handler_bootstrip (c_launch_data* data, SCM tag, SCM throw_args) |
|
|
{ |
|
|
scm_root->rootcont = data->u.rootcont; |
|
|
return (data->handler) (data->handler_data, tag, throw_args); |
|
|
} |
|
|
|
|
|
static void |
|
|
c_really_launch (void *p) |
|
|
{ |
|
|
SCM result; |
|
|
c_launch_data *data = (c_launch_data *) p; |
|
|
/* The thread object will be GC protected by being on this stack */ |
|
|
SCM thread = data->u.thread; |
|
|
scm_copt_thread *t = SCM_THREAD_DATA (thread); |
|
|
/* We must use the address of `thread', otherwise the compiler will |
|
|
optimize it away. This is OK since the longest SCM_STACKITEM |
|
|
also is a long. */ |
|
|
result = scm_internal_cwdr ((scm_t_catch_body) c_body_bootstrip, |
|
|
data, |
|
|
(scm_t_catch_handler) c_handler_bootstrip, |
|
|
data, |
|
|
(SCM_STACKITEM *) &thread); |
|
|
all_threads = scm_delq (thread, all_threads); |
|
|
t->result = result; |
|
|
pthread_detach (t->pthread); |
|
|
t->pthread = -1; |
|
|
thread_count--; |
|
|
free ((char *) data); |
|
|
} |
|
|
|
|
|
static void * |
|
|
c_launch_thread (void *p) |
|
|
{ |
|
|
ticket t; |
|
|
enter_guile ((SCM_STACKITEM *)&t, &t); |
|
|
c_really_launch (p); |
|
|
leave_guile (&t); |
|
|
return NULL; |
|
|
} |
|
|
|
|
|
SCM |
|
|
scm_spawn_thread (scm_t_catch_body body, void *body_data, |
|
|
scm_t_catch_handler handler, void *handler_data) |
|
|
{ |
|
|
SCM thread; |
|
|
pthread_t th; |
|
|
SCM root, old_winds; |
|
|
c_launch_data *data = (c_launch_data *) scm_malloc (sizeof (*data)); |
|
|
|
|
|
/* Unwind wind chain. */ |
|
|
old_winds = scm_dynwinds; |
|
|
scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds)); |
|
|
|
|
|
/* Allocate thread locals. */ |
|
|
root = scm_make_root (scm_root->handle); |
|
|
/* Make thread. */ |
|
|
thread = make_thread (); |
|
|
SCM_DEFER_INTS; |
|
|
|
|
|
data->u.thread = thread; |
|
|
data->body = body; |
|
|
data->body_data = body_data; |
|
|
data->handler = handler; |
|
|
data->handler_data = handler_data; |
|
|
|
|
|
pthread_create (&th, NULL, c_launch_thread, (void *) data); |
|
|
init_thread_creator (thread, th, SCM_ROOT_STATE (root)); |
|
|
all_threads = scm_cons (thread, all_threads); |
|
|
thread_count++; |
|
|
SCM_ALLOW_INTS; |
|
|
|
|
|
/* Return to old dynamic context. */ |
|
|
scm_dowinds (old_winds, - scm_ilength (old_winds)); |
|
|
|
|
|
return thread; |
|
|
} |
|
|
#endif |
|
|
|
|
1058 |
/* |
/* |
1059 |
Local Variables: |
Local Variables: |
1060 |
c-file-style: "gnu" |
c-file-style: "gnu" |