/[guile]/guile/guile-core/libguile/coop-pthreads.c
ViewVC logotype

Diff of /guile/guile-core/libguile/coop-pthreads.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4 by mvo, Sat Nov 2 01:02:35 2002 UTC revision 1.5 by mvo, Sun Nov 3 00:48:41 2002 UTC
# Line 118  typedef struct scm_copt_thread { Line 118  typedef struct scm_copt_thread {
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);
# Line 154  static SCM Line 154  static SCM
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;
# Line 183  static size_t Line 180  static size_t
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");
# Line 414  int scm_i_switch_counter; Line 408  int scm_i_switch_counter;
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      {      {
# Line 466  unblock (scm_copt_thread *t) Line 458  unblock (scm_copt_thread *t)
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);
# Line 512  really_launch (SCM_STACKITEM *base, SCM Line 508  really_launch (SCM_STACKITEM *base, SCM
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,
# Line 556  scm_call_with_new_thread (SCM argl) Line 530  scm_call_with_new_thread (SCM argl)
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++;
# Line 576  scm_call_with_new_thread (SCM argl) Line 558  scm_call_with_new_thread (SCM argl)
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
# Line 1033  scm_c_thread_exited_p (SCM thread) Line 1055  scm_c_thread_exited_p (SCM thread)
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"

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26