/[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.1 by mvo, Sun Oct 27 20:26:21 2002 UTC revision 1.2 by mvo, Wed Oct 30 10:41:51 2002 UTC
# Line 54  Line 54 
54    
55  #undef DEBUG  #undef DEBUG
56    
57  static pthread_mutex_t guile_mutex = PTHREAD_MUTEX_INITIALIZER;  /* This thread implementation uses POSIX threads but allows only
58  pthread_t guile_thread;     thread to really execute at any one time.
59    
60  static SCM all_threads;     XXX - more overview here.
61  static int thread_count;  */
62    
63  static pthread_key_t handle_key;  /* All data is protected by a single mutex: guile_mutex. */
64    
65  /* The following functions are for managing a threads visit in Guile  static pthread_mutex_t guile_mutex = PTHREAD_MUTEX_INITIALIZER;
66     land.  A thread can be in one of three states: outside, active, or  
67     suspended.  "Outside" means that the thread can not call any Guile  /*** Threads */
    related functions and can not store SCM values in local variables.  
    "Active" or "suspended" means that a thread can use Guile and can  
    store SCM values in its stack.  An "active" thread is currently  
    executing while a "suspended" one is waiting to become active  
    again.  There can only be one "active" thread at any one time.  
 */  
68    
69  typedef struct ticket {  typedef struct scm_copt_thread {
70    struct ticket *next;    
71    struct ticket **prevp;    /* A condition variable for sleeping on.
72       */
73      pthread_cond_t sleep_cond;
74    
75      /* A link for the ready queue.
76       */
77      struct scm_copt_thread *next_ready;
78    
79      scm_root_state *root;
80      SCM handle;
81      pthread_t pthread;
82      SCM result;
83    
84      /* For keeping track of the stack and registers. */
85    SCM_STACKITEM *base;    SCM_STACKITEM *base;
86    SCM_STACKITEM *top;    SCM_STACKITEM *top;
87    jmp_buf regs;    jmp_buf regs;
 } ticket;  
88    
89  static ticket *tickets = NULL;  } scm_copt_thread;
 static pthread_key_t ticket_key;  
90    
91  /* Enter Guile land.  While in Guile land, the stack between BASE and  static SCM
92     the current stack pointer will be scanned for SCM references.  Only  make_thread (SCM args)
    one thread can be in Guile land at any one time.  When you try to  
    enter it while another one is already there, you will be put to  
    sleep until it leaves or suspends.  
  */  
 static void  
 enter_guile (SCM_STACKITEM *base, ticket *t)  
93  {  {
94    pthread_mutex_lock (&guile_mutex);    SCM z;
95    guile_thread = pthread_self ();    scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread");
96      z = scm_cell (scm_tc16_thread, (scm_t_bits)t);
97  #ifdef DEBUG    t->handle = z;
98    fprintf (stderr, "thread %ld entered\n", pthread_self ());    t->result = args;
99  #endif    return z;
100    }
101    
102    /* Ok, we are in.  Stamp our ticket. */  static void
103    t->next = tickets;  init_thread_creator (SCM thread, pthread_t th, scm_root_state *r)
104    if (tickets)  {
105      tickets->prevp = &t->next;    scm_copt_thread *t = SCM_THREAD_DATA(thread);
106    tickets = t;    t->root = r;
107    t->prevp = &tickets;    t->pthread = th;
108      pthread_cond_init (&t->sleep_cond, NULL);
109    }
110    
111    static void
112    init_thread_creatant (SCM thread, SCM_STACKITEM *base)
113    {
114      scm_copt_thread *t = SCM_THREAD_DATA(thread);
115    t->base = base;    t->base = base;
116    t->top = NULL;    t->top = NULL;
117    }
118    
119    pthread_setspecific (ticket_key, (void *)t);  static SCM
120    thread_mark (SCM obj)
121    {
122      scm_copt_thread *t = SCM_THREAD_DATA (obj);
123      scm_gc_mark (t->result);
124      return t->root->handle;
125  }  }
126    
127  /* Leave Guile land so that the next thread can enter.  This function  static int
128     must be called from the same stack frame as the corresponding  thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
    enter_guile.  The stack of this thread will no longer be scanned.  
 */  
 static void  
 leave_guile (ticket *t)  
129  {  {
130    /* Remove ticket... */    scm_copt_thread *t = SCM_THREAD_DATA (exp);
131    *t->prevp = t->next;    scm_puts ("#<thread ", port);
132    if (t->next)    scm_intprint ((unsigned long)t, 16, port);
133      t->next->prevp = t->prevp;    if (t->pthread != -1)
134        {
135          scm_putc (' ', port);
136          scm_intprint (t->pthread, 10, port);
137        }
138      else
139        scm_puts (" (exited)", port);
140      scm_putc ('>', port);
141      return 1;
142    }
143    
144  #ifdef DEBUG  static size_t
145    fprintf (stderr, "thread %ld left\n", pthread_self ());  thread_free (SCM obj)
146  #endif  {
147      scm_copt_thread *t = SCM_THREAD_DATA (obj);
148      if (t->pthread != -1)
149        abort ();
150      scm_gc_free (t, sizeof (*t), "thread");
151      return 0;
152    }
153    
154    /* ...and leave. */  /*** Queues */
155    guile_thread = 0;  
156    pthread_mutex_unlock (&guile_mutex);  static SCM
157    make_queue ()
158    {
159      return scm_cons (SCM_EOL, SCM_EOL);
160    }
161    
162    static void
163    enqueue (SCM q, SCM t)
164    {
165      SCM c = scm_cons (t, SCM_EOL);
166      if (SCM_NULLP (SCM_CAR (q)))
167        SCM_SETCAR (q, c);
168      else
169        SCM_SETCDR (SCM_CDR (q), c);
170      SCM_SETCDR (q, c);
171  }  }
172    
173  /* Suspend the visit in Guile land so that other threads can resume  static SCM
174     their visit or enter.  While a thread is suspended, its stack is  dequeue (SCM q)
175     scanned between BASE (as given to enter_guile) and TOP (as given  {
176     here).    SCM c = SCM_CAR (q);
177      if (SCM_NULLP (c))
178        return SCM_BOOL_F;
179      else
180        {
181          SCM_SETCAR (q, SCM_CDR (c));
182          if (SCM_NULLP (SCM_CAR (q)))
183            SCM_SETCDR (q, SCM_EOL);
184          return SCM_CAR (c);
185        }
186    }
187    
188    /*** Ready queue */
189    
190    /* Normally, queues are implemented with the procedures above, but the
191       ready queue is special.  We need to put threads on it from the
192       'outside', i.e., when we don't hold the guile_mutex.  That's why
193       the ready queue has its own mutex and isn't implemented with SCM
194       objects.
195  */  */
196  static ticket *  
197  suspend_guile ()  static pthread_mutex_t ready_queue_mutex = PTHREAD_MUTEX_INITIALIZER;
198    static scm_copt_thread *next_ready = NULL;
199    static scm_copt_thread *last_ready = NULL;
200    
201    static void
202    get_ready (scm_copt_thread *t)
203  {  {
204    ticket *t = pthread_getspecific (ticket_key);    pthread_mutex_lock (&ready_queue_mutex);
205      t->next_ready = NULL;
206      if (last_ready)
207        last_ready->next_ready = t;
208      else
209        next_ready = t;
210      last_ready = t;
211      pthread_mutex_unlock (&ready_queue_mutex);
212    }
213    
214    if (t == NULL)  static scm_copt_thread *
215      abort ();  get_next_ready ()
216    {
217      scm_copt_thread *t;
218      pthread_mutex_lock (&ready_queue_mutex);
219      t = next_ready;
220      if (t)
221        {
222          next_ready = t->next_ready;
223          if (next_ready == NULL)
224            last_ready = NULL;
225        }
226      return t;
227      pthread_mutex_unlock (&ready_queue_mutex);
228    }
229    
230    /*** Running and sleeping */
231    
232    static SCM cur_thread;
233    
234    /* Kick the next runnable thread if there is one.
235     */
236    static void
237    kick_next ()
238    {
239      scm_copt_thread *next = get_next_ready (ready_queue);
240      if (next)
241        pthread_cond_signal (&next->sleep_cond);
242    }
243      
244    static SCM
245    suspend ()
246    {
247      SCM cur = cur_thread;
248      scm_copt_thread *c = SCM_THREAD_DATA (cur);
249    
250    /* Record top of stack...*/    /* record top of stack for the GC */
251    t->top = (SCM_STACKITEM *)&t;    c->top = (SCM_STACKITEM *)&c;
252    /* ...save registers for the GC...*/    /* save registers. */
253    SCM_FLUSH_REGISTER_WINDOWS;    SCM_FLUSH_REGISTER_WINDOWS;
254    setjmp (t->regs);    setjmp (c->regs);
255    
256  #ifdef DEBUG    return cur;
257    fprintf (stderr, "thread %ld suspended\n", pthread_self ());  }
 #endif  
258    
259    /* ... and leave temporarily. */  static void
260    guile_thread = 0;  release ()
261    {
262    pthread_mutex_unlock (&guile_mutex);    pthread_mutex_unlock (&guile_mutex);
   return t;  
263  }  }
264    
 /* Resume the visit.  This must be called from the same frame as the  
    corresponding suspend_guile.  
 */  
265  static void  static void
266  resume_guile (ticket *t)  acquire ()
267  {  {
268      please = 1;
269    pthread_mutex_lock (&guile_mutex);    pthread_mutex_lock (&guile_mutex);
   guile_thread = pthread_self ();  
 #ifdef DEBUG  
   fprintf (stderr, "thread %ld resumed\n", pthread_self ());  
 #endif  
   t->top = NULL;  
270  }  }
271    
 static ticket main_ticket;  
   
 int scm_switch_counter;  
   
272  static void  static void
273  init_queue (scm_copt_queue *q)  resume (SCM cur)
274  {  {
275    q->first = NULL;    scm_copt_thread *c = SCM_THREAD_DATA (cur);
276    q->lastp = &q->first;    cur_thread = cur;
277      c->top = NULL;
278  }  }
279    
280  static void  static void
281  enqueue (scm_copt_queue *q, scm_copt_thread *t)  block ()
282  {  {
283    t->prevp = q->lastp;    SCM cur = suspend ();
284    t->next = NULL;    scm_copt_thread *c = SCM_THREAD_DATA (cur);
285    *t->prevp = t;    pthread_cond_wait (&c->sleep_cond, &guile_mutex);
286    q->lastp = &t->next;    resume (cur);
287  }  }
288    
289  static scm_copt_thread *  /* Yielding consists of getting the next thread from the ready_queue
290  dequeue (scm_copt_queue *q)     and if there is one, putting ourselves on the ready queue and
291       block.
292    */
293    SCM
294    scm_yield ()
295  {  {
296    scm_copt_thread *t = q->first;    scm_copt_thread *next = get_next_ready ();
297    if (t)    if (next)
298      {      {
299        *t->prevp = t->next;        pthread_cond_signal (&next->sleep_cond);
300        if (t->next)        get_ready (SCM_THREAD_DATA (cur_thread));
301          t->next->prevp = t->prevp;        block ();
       else  
         q->lastp = t->prevp;  
302      }      }
303    return t;    return SCM_BOOL_T;
304    }
305    
306    int scm_switch_counter;
307    
308    /*** Thread creation */
309    
310    static SCM all_threads;
311    static int thread_count;
312    
313    typedef struct scheme_launch_data {
314      SCM rootcont;
315      SCM body;
316      SCM handler;
317    } scheme_launch_data;
318    
319    static SCM
320    scheme_body_bootstrip (scheme_launch_data* data)
321    {
322      /* First save the new root continuation */
323      data->rootcont = scm_root->rootcont;
324      return scm_call_0 (data->body);
325  }  }
326    
327  static SCM  static SCM
328  make_thread ()  scheme_handler_bootstrip (scheme_launch_data* data, SCM tag, SCM throw_args)
329  {  {
330    SCM z;    scm_root->rootcont = data->rootcont;
331    scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread");    return scm_apply_1 (data->handler, tag, throw_args);
   z = scm_cell (scm_tc16_thread, (scm_t_bits)t);  
   t->handle = z;  
   return z;  
332  }  }
333    
334  static void  static void
335  init_thread_creator (SCM thread, pthread_t th, scm_root_state *r)  really_launch (SCM_STACKITEM *base, SCM thread)
336  {  {
337    scm_copt_thread *t = SCM_THREAD_DATA(thread);    scm_copt_thread *t = SCM_THREAD_DATA (thread);
338    t->root = r;    scheme_launch_data data;
339    t->pthread = th;    init_thread_creatant (thread, base);
340    t->result = SCM_BOOL_F;    resume (thread);
341    pthread_cond_init (&t->block, NULL);  
342      /* Ok, we bullied our way in, now be nice and stand in queue.
343       */
344      scm_yield ();
345    
346      data.rootcont = SCM_BOOL_F;
347      data.body = SCM_CAR (t->result);
348      data.handler = SCM_CADR (t->result);
349      t->result =
350        scm_internal_cwdr ((scm_t_catch_body) scheme_body_bootstrip,
351                           &data,
352                           (scm_t_catch_handler) scheme_handler_bootstrip,
353                           &data, base);
354      pthread_detach (t->pthread);
355    
356      {
357        SCM next = dequeue (ready_queue);
358        if (!SCM_FALSEP (next))
359          {
360            scm_copt_thread *n = SCM_THREAD_DATA (next);
361            pthread_cond_signal (&n->sleep_cond);
362          }
363      }
364    
365      all_threads = scm_delq (thread, all_threads);
366      t->pthread = -1;
367      thread_count--;
368      suspend ();
369  }  }
370    
371  static void  static void *
372  init_thread_creatant (SCM thread)  scheme_launch_thread (void *p)
373  {  {
374    scm_copt_thread *t = SCM_THREAD_DATA(thread);    acquire ();
375    pthread_setspecific (handle_key, t);    really_launch ((SCM_STACKITEM *)&p, (SCM)p);
376      release ();
377      return NULL;
378    }
379    
380    
381    SCM
382    scm_call_with_new_thread (SCM argl)
383    #define FUNC_NAME s_call_with_new_thread
384    {
385      SCM thread;
386    
387      /* Check arguments. */
388      {
389        register SCM args = argl;
390        SCM thunk, handler;
391        if (!SCM_CONSP (args))
392          SCM_WRONG_NUM_ARGS ();
393        thunk = SCM_CAR (args);
394        SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)),
395                    thunk,
396                    SCM_ARG1,
397                    s_call_with_new_thread);
398        args = SCM_CDR (args);
399        if (!SCM_CONSP (args))
400          SCM_WRONG_NUM_ARGS ();
401        handler = SCM_CAR (args);
402        SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)),
403                    handler,
404                    SCM_ARG2,
405                    s_call_with_new_thread);
406        if (!SCM_NULLP (SCM_CDR (args)))
407          SCM_WRONG_NUM_ARGS ();
408      }
409    
410      /* Make new thread.  The first thing the new thread will do is to
411         lock guile_mutex.  Thus, we can safely complete its
412         initialization after creating it.  While the new thread starts,
413         all its data is protected via all_threads.
414       */
415    
416      {
417        pthread_t th;
418        SCM root, old_winds;
419        
420        /* Unwind wind chain. */
421        old_winds = scm_dynwinds;
422        scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
423    
424        /* Allocate thread locals. */
425        root = scm_make_root (scm_root->handle);
426        /* Make thread. */
427        thread = make_thread (argl);
428        SCM_DEFER_INTS;
429        pthread_create (&th, NULL, scheme_launch_thread, (void *) thread);
430        init_thread_creator (thread, th, SCM_ROOT_STATE (root));
431        all_threads = scm_cons (thread, all_threads);
432        thread_count++;
433    #ifdef DEBUG
434        fprintf (stderr, "thread %ld created\n", th);
435    #endif
436        SCM_ALLOW_INTS;
437    
438        /* Return to old dynamic context. */
439        scm_dowinds (old_winds, - scm_ilength (old_winds));
440      }
441      
442      return thread;
443  }  }
444    #undef FUNC_NAME
445    
446    /*** Mutexes */
447    
448    /* We implement our own mutex type since we want them to be 'fair',
449       we want to do fancy things while waiting for them (like running
450       asyncs) and we want to support waiting on many things at once.
451    */
452    
453    typedef struct scm_copt_mutex {
454      /* the thread currently owning the mutex, or SCM_BOOL_F. */
455      SCM owner;
456      /* how much the owner owns us. */
457      int level;
458      /* the threads waiting for this mutex. */
459      SCM waiting;
460    } scm_copt_mutex;
461    
462  static SCM  static SCM
463  thread_mark (SCM obj)  mutex_mark (SCM mx)
464  {  {
465    scm_copt_thread *t = SCM_THREAD_DATA (obj);    scm_copt_mutex *m = SCM_MUTEX_DATA (mx);
466    scm_gc_mark (t->result);    scm_gc_mark (m->owner);
467    return t->root->handle;    return m->waiting;
468  }  }
469    
470  static int  SCM
471  thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)  scm_make_mutex ()
472  {  {
473    scm_copt_thread *t = SCM_THREAD_DATA (exp);    SCM mx = scm_make_smob (scm_tc16_mutex);
474    scm_puts ("#<thread ", port);    scm_copt_mutex *m = SCM_MUTEX_DATA (mx);
475    scm_intprint ((unsigned long)t, 16, port);    m->owner = SCM_BOOL_F;
476    if (t->pthread != -1)    m->level = 0;
477      m->waiting = make_queue ();
478      return mx;
479    }
480    
481    SCM
482    scm_lock_mutex (SCM mx)
483    #define FUNC_NAME s_lock_mutex
484    {
485      scm_copt_mutex *m;
486      SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
487      m = SCM_MUTEX_DATA (mx);
488    
489      if (m->owner == SCM_BOOL_F)
490        m->owner = cur_thread;
491      else if (m->owner == cur_thread)
492        m->level++;
493      else
494      {      {
495        scm_putc (' ', port);        while (m->owner != cur_thread)
496        scm_intprint (t->pthread, 10, port);          {
497              enqueue (m->waiting, cur_thread);
498              kick_next ();
499              block ();
500              SCM_ASYNC_TICK;
501            }
502      }      }
503    else    return SCM_BOOL_T;
     scm_puts (" (exited)", port);  
   scm_putc ('>', port);  
   return 1;  
504  }  }
505    #undef FUNC_NAME
506    
507  static size_t  SCM
508  thread_free (SCM obj)  scm_unlock_mutex (SCM mx)
509    #define FUNC_NAME s_lock_mutex
510  {  {
511    scm_copt_thread *t = SCM_THREAD_DATA (obj);    scm_copt_mutex *m;
512    if (t->pthread != -1)    SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
513      abort ();    m = SCM_MUTEX_DATA (mx);
514    scm_gc_free (t, sizeof (*t), "thread");  
515    return 0;    if (m->owner != cur_thread)
516        {
517          if (m->owner == SCM_BOOL_F)
518            SCM_MISC_ERROR ("mutex not locked", SCM_EOL);
519          else
520            SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL);
521        }
522      else if (m->level > 0)
523        m->level--;
524      else
525        {
526          SCM next = dequeue (m->waiting);
527          if (!SCM_FALSEP (next))
528            {
529              m->owner = next;
530              enqueue (ready_queue, next);
531              scm_yield ();
532            }
533          else
534            m->owner = SCM_BOOL_F;
535        }
536      return SCM_BOOL_T;
537  }  }
538    #undef FUNC_NAME
539    
540  static scm_copt_queue yield_queue;  /*** Initialization */
541    
542  void  void
543  scm_threads_init (SCM_STACKITEM *base)  scm_threads_init (SCM_STACKITEM *base)
544  {  {
545    SCM main_thread;    scm_tc16_thread = scm_make_smob_type ("thread", 0);
546    pthread_key_create (&handle_key, NULL);    scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_copt_mutex));
547    pthread_key_create (&ticket_key, NULL);    scm_tc16_condvar = scm_make_smob_type ("condition-variable", 0);
548    
549    scm_switch_counter = SCM_THREAD_SWITCH_COUNT;    scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
550    enter_guile (base, &main_ticket);  
551    main_thread = make_thread ();    acquire ();
552      cur_thread = make_thread (SCM_BOOL_F);
553    /* root is set later from init.c */    /* root is set later from init.c */
554    init_thread_creator (main_thread, pthread_self(), NULL);    init_thread_creator (cur_thread, pthread_self(), NULL);
555    init_thread_creatant (main_thread);    init_thread_creatant (cur_thread, base);
556    scm_gc_register_root (&all_threads);    resume (cur_thread);
   all_threads = scm_cons (main_thread, SCM_EOL);  
557    thread_count = 1;    thread_count = 1;
558      scm_gc_register_root (&all_threads);
559      all_threads = scm_cons (cur_thread, SCM_EOL);
560    
561    scm_set_smob_mark (scm_tc16_thread, thread_mark);    scm_set_smob_mark (scm_tc16_thread, thread_mark);
562    scm_set_smob_print (scm_tc16_thread, thread_print);    scm_set_smob_print (scm_tc16_thread, thread_print);
563    scm_set_smob_free (scm_tc16_thread, thread_free);    scm_set_smob_free (scm_tc16_thread, thread_free);
564    init_queue (&yield_queue);  
565      scm_set_smob_mark (scm_tc16_mutex, mutex_mark);
566    
567      ready_queue = scm_permanent_object (make_queue ());
568  }  }
569    
570    /*** Marking stacks */
571    
572  /* XXX - what to do with this?  Do we need to handle this for blocked  /* XXX - what to do with this?  Do we need to handle this for blocked
573     threads as well?     threads as well?
574  */  */
# Line 318  scm_threads_init (SCM_STACKITEM *base) Line 590  scm_threads_init (SCM_STACKITEM *base)
590  void  void
591  scm_threads_mark_stacks (void)  scm_threads_mark_stacks (void)
592  {  {
593    ticket *t;    volatile SCM c;
594      for (c = all_threads; !SCM_NULLP (c); c = SCM_CDR (c))
   for (t = tickets; t; t = t->next)  
595      {      {
596          scm_copt_thread *t = SCM_THREAD_DATA (SCM_CAR (c));
597          if (t->base == NULL)
598            {
599              /* Not fully initialized yet. */
600              continue;
601            }
602        if (t->top == NULL)        if (t->top == NULL)
603          {          {
604            /* Active thread */            /* Active thread */
# Line 388  scm_threads_mark_stacks (void) Line 665  scm_threads_mark_stacks (void)
665      }      }
666  }  }
667    
668  /* NOTE: There are TWO mechanisms for starting a thread: The first one  /*** Select */
    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.  */  
669    
670  /* This is the first thread spawning mechanism: threads from Scheme */  #include "libguile/iselect.h"
671    
672  typedef struct scheme_launch_data {  int
673    SCM rootcont;  scm_internal_select (int nfds,
674    SCM body;                       SELECT_TYPE *readfds,
675    SCM handler;                       SELECT_TYPE *writefds,
676  } scheme_launch_data;                       SELECT_TYPE *exceptfds,
677                         struct timeval *timeout)
678    {
679      int res;
680      SCM cur = suspend ();
681      release ();
682      res = select (nfds, readfds, writefds, exceptfds, timeout);
683      acquire ();
684      resume (cur);
685      SCM_ASYNC_TICK;
686      return res;
687    }
688    
689  static SCM  void
690  scheme_body_bootstrip (scheme_launch_data* data)  scm_init_iselect ()
691  {  {
   /* First save the new root continuation */  
   data->rootcont = scm_root->rootcont;  
   return scm_call_0 (data->body);  
692  }  }
693    
694  static SCM  /*** Misc */
695  scheme_handler_bootstrip (scheme_launch_data* data, SCM tag, SCM throw_args)  
696    SCM
697    scm_current_thread (void)
698  {  {
699    scm_root->rootcont = data->rootcont;    return cur_thread;
   return scm_apply_1 (data->handler, tag, throw_args);  
700  }  }
701    
702  static void  SCM
703  really_launch (void *p)  scm_all_threads (void)
704  {  {
705    SCM argl = (SCM) p;    return all_threads;
   SCM thread = SCM_CAR (argl);  
   scm_copt_thread *t = SCM_THREAD_DATA (thread);  
   SCM result;  
   scheme_launch_data data;  
   init_thread_creatant (thread);  
   data.rootcont = SCM_BOOL_F;  
   data.body = SCM_CADR (argl);  
   data.handler = SCM_CADDR (argl);  
   result = scm_internal_cwdr ((scm_t_catch_body) scheme_body_bootstrip,  
                               &data,  
                               (scm_t_catch_handler) scheme_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--;  
706  }  }
707    
708  static void *  scm_root_state *
709  scheme_launch_thread (void *p)  scm_i_thread_root (SCM thread)
710  {  {
711    ticket t;    return ((scm_copt_thread *)SCM_THREAD_DATA (thread))->root;
   enter_guile ((SCM_STACKITEM *)&t, &t);  
   really_launch (p);  
   leave_guile (&t);  
   return NULL;  
712  }  }
713    
714    void *
715    scm_copt_thread_data (void)
716    {
717      scm_copt_thread *t = SCM_THREAD_DATA (cur_thread);
718      return t->root;
719    }
720    
721  SCM  void
722  scm_call_with_new_thread (SCM argl)  scm_copt_set_thread_data (void *d)
 #define FUNC_NAME s_call_with_new_thread  
723  {  {
724    SCM thread;    scm_copt_thread *t = SCM_THREAD_DATA (cur_thread);
725      t->root = d;
726    }
727    
728    /* Check arguments. */  /* XXX from here to end */
   {  
     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 ();  
   }  
729    
730    /* Make new thread.  The first thing the new thread will do is to  #if 0
731       call enter_guile.  Thus, we can safely complete its  /* NOTE: There are TWO mechanisms for starting a thread: The first one
732       initialization after creating it. */     is used when spawning a thread from Scheme, while the second one is
733    {     used from C.
     pthread_t th;  
     SCM root, old_winds;  
       
     /* Unwind wind chain. */  
     old_winds = scm_dynwinds;  
     scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));  
734    
735      /* Allocate thread locals. */     It might be argued that the first should be implemented in terms of
736      root = scm_make_root (scm_root->handle);     the second.  The reason it isn't is that that would require an
737      /* Make thread. */     extra unnecessary malloc (the thread_args structure).  By providing
738      thread = make_thread ();     one pair of extra functions (c_launch_thread, scm_spawn_thread) the
739      SCM_DEFER_INTS;     Scheme threads are started more efficiently.  */
740      argl = scm_cons (thread, argl);  
741      /* Note that we couldn't pass a pointer to argl as data since the  /* This is the first thread spawning mechanism: threads from Scheme */
        argl variable may not exist in memory when the thread starts.  */  
     pthread_create (&th, NULL, scheme_launch_thread, (void *) argl);  
     init_thread_creator (thread, th, SCM_ROOT_STATE (root));  
     all_threads = scm_cons (thread, all_threads);  
     thread_count++;  
 #ifdef DEBUG  
     fprintf (stderr, "thread %ld created\n", th);  
 #endif  
     SCM_ALLOW_INTS;  
742    
     /* Return to old dynamic context. */  
     scm_dowinds (old_winds, - scm_ilength (old_winds));  
   }  
     
   return thread;  
 }  
 #undef FUNC_NAME  
743    
744    
745  /* This is the second thread spawning mechanism: threads from C */  /* This is the second thread spawning mechanism: threads from C */
# Line 620  scm_spawn_thread (scm_t_catch_body body, Line 840  scm_spawn_thread (scm_t_catch_body body,
840        
841    return thread;    return thread;
842  }  }
843    #endif
 SCM  
 scm_current_thread (void)  
 {  
   scm_copt_thread *t = pthread_getspecific (handle_key);  
   if (t == NULL)  
     abort ();   /* XXX - should ceate a new handle. */  
   else  
     return t->handle;  
 }  
   
 SCM  
 scm_all_threads (void)  
 {  
   return all_threads;  
 }  
   
 scm_root_state *  
 scm_i_thread_root (SCM thread)  
 {  
   return ((scm_copt_thread *)SCM_THREAD_DATA (thread))->root;  
 }  
844    
845  SCM  SCM
846  scm_join_thread (SCM thread)  scm_join_thread (SCM thread)
847  #define FUNC_NAME s_join_thread  #define FUNC_NAME s_join_thread
848  {  {
849    #if 0
850    scm_copt_thread *t;    scm_copt_thread *t;
851    SCM res;    SCM res;
852    
# Line 662  scm_join_thread (SCM thread) Line 862  scm_join_thread (SCM thread)
862    res = t->result;    res = t->result;
863    t->result = SCM_BOOL_F;    t->result = SCM_BOOL_F;
864    return res;    return res;
865    #endif
866      return SCM_BOOL_F;
867  }  }
868  #undef FUNC_NAME  #undef FUNC_NAME
869    
# Line 677  scm_c_thread_exited_p (SCM thread) Line 879  scm_c_thread_exited_p (SCM thread)
879  #undef FUNC_NAME  #undef FUNC_NAME
880    
881  SCM  SCM
 scm_yield (void)  
 {  
   fprintf (stderr, "yield\n");  
   if (yield_queue.first)  
     {  
       ticket *t;  
       scm_copt_thread *me = pthread_getspecific (handle_key);  
       scm_copt_thread *next = dequeue (&yield_queue);  
       enqueue (&yield_queue, me);  
       pthread_cond_signal (&next->block);  
       t = suspend_guile_2 ();  
       pthread_cond_wait (&me->block, &guile_mutex);  
       resume_guile_2 (t);  
     }  
   return SCM_BOOL_T;  
 }  
   
 void  
 scm_copt_mutex_init (scm_copt_mutex *m)  
 {  
   pthread_mutex_init (&m->mutex, NULL);  
   m->owner = NULL;  
   m->level = 0;  
   init_queue (&m->waiting);  
 }  
   
 void  
 scm_copt_mutex_destroy (scm_copt_mutex *m)  
 {  
   pthread_mutex_destroy (&m->mutex);  
 }  
   
 void  
 scm_copt_mutex_lock (scm_copt_mutex *m)  
 {  
   scm_copt_thread *t = pthread_getspecific (handle_key);  
   pthread_mutex_lock (&m->mutex);  
   if (m->owner == t)  
     m->level++;  
   else if (m->owner == NULL)  
     {  
       m->owner = t;  
     }  
   else  
     {  
       enqueue (&m->waiting, t);  
       do  
         {  
           ticket *tt = suspend_guile ();  
           pthread_cond_wait (&t->block, &m->mutex);  
           resume_guile (tt);  
           SCM_ASYNC_TICK;  
         }  
       while (m->owner != t);  
     }  
   pthread_mutex_unlock (&m->mutex);  
 }  
   
 void  
 scm_copt_mutex_unlock (scm_copt_mutex *m)  
 {  
   pthread_mutex_lock (&m->mutex);  
   if (m->level == 0)  
     {  
       scm_copt_thread *t = dequeue (&m->waiting);  
       m->owner = t;  
       if (t)  
         pthread_cond_signal (&t->block);  
     }  
   else  
     m->level--;  
   pthread_mutex_unlock (&m->mutex);  
 }  
   
 SCM  
 scm_make_mutex (void)  
 {  
   SCM m = scm_make_smob (scm_tc16_mutex);  
   scm_copt_mutex_init (SCM_MUTEX_DATA (m));  
   return m;  
 }  
   
 SCM  
 scm_lock_mutex (SCM m)  
 {  
   ticket *t;  
   SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex);  
   t = suspend_guile ();  
   scm_copt_mutex_lock (SCM_MUTEX_DATA (m));  
   resume_guile (t);  
   return SCM_BOOL_T;  
 }  
   
 SCM  
 scm_unlock_mutex (SCM m)  
 {  
   SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_unlock_mutex);  
   scm_copt_mutex_unlock(SCM_MUTEX_DATA (m));  
   return SCM_BOOL_T;  
 }  
   
 SCM  
882  scm_make_condition_variable (void)  scm_make_condition_variable (void)
883  {  {
884    SCM c = scm_make_smob (scm_tc16_condvar);    abort ();
   pthread_cond_init (SCM_CONDVAR_DATA (c), NULL);  
   return c;  
885  }  }
886    
887  SCM  SCM
888  scm_wait_condition_variable (SCM c, SCM m)  scm_timed_wait_condition_variable (SCM c, SCM m, SCM t)
889  {  {
890    ticket *t;    abort ();
   SCM_ASSERT (SCM_CONDVARP (c),  
               c,  
               SCM_ARG1,  
               s_wait_condition_variable);  
   SCM_ASSERT (SCM_MUTEXP (m),  
               m,  
               SCM_ARG2,  
               s_wait_condition_variable);  
   t = suspend_guile ();  
   pthread_cond_wait (SCM_CONDVAR_DATA (c), SCM_MUTEX_DATA (m));  
   resume_guile (t);  
   return SCM_BOOL_T;  
891  }  }
892    
893  SCM  SCM
894  scm_signal_condition_variable (SCM c)  scm_signal_condition_variable (SCM c)
895  {  {
896    SCM_ASSERT (SCM_CONDVARP (c),    abort ();
               c,  
               SCM_ARG1,  
               s_signal_condition_variable);  
   pthread_cond_signal (SCM_CONDVAR_DATA (c));  
   return SCM_BOOL_T;  
 }  
   
 void *  
 scm_copt_thread_data (void)  
 {  
   scm_copt_thread *t = pthread_getspecific (handle_key);  
   if (t == NULL)  
     abort ();  
   else  
     return t->root;  
 }  
   
 void  
 scm_copt_set_thread_data (void *d)  
 {  
   scm_copt_thread *t = pthread_getspecific (handle_key);  
   if (t == NULL)  
     abort ();  
   else  
     t->root = d;  
897  }  }
898    
899  unsigned long  unsigned long
900  scm_thread_usleep (unsigned long usec)  scm_thread_usleep (unsigned long usec)
901  {  {
902    ticket *t;    return usleep (usec);
   unsigned long ret;  
   t = suspend_guile ();  
   ret = usleep (usec);  
   resume_guile (t);  
   return ret;  
903  }  }
904    
905  unsigned long  unsigned long
906  scm_thread_sleep (unsigned long sec)  scm_thread_sleep (unsigned long sec)
907  {  {
908    ticket *t;    return sleep (sec);
   unsigned long ret;  
   t = suspend_guile ();  
   ret = sleep (sec);  
   resume_guile (t);  
   return ret;  
909  }  }
910    
 #include "libguile/iselect.h"  
911    
912  int  SCM
913  scm_internal_select (int nfds,  scm_try_mutex (SCM mx)
                      SELECT_TYPE *readfds,  
                      SELECT_TYPE *writefds,  
                      SELECT_TYPE *exceptfds,  
                      struct timeval *timeout)  
914  {  {
915    ticket *t;    abort ();
   int res;  
   t = suspend_guile ();  
   res = select (nfds, readfds, writefds, exceptfds, timeout);  
   resume_guile (t);  
   SCM_ASYNC_TICK;  
   return res;  
916  }  }
917    
918  void  SCM
919  scm_init_iselect ()  scm_broadcast_condition_variable (SCM cv)
920  {  {
921      abort ();
922  }  }
923    
924    
925  /*  /*
926    Local Variables:    Local Variables:
927    c-file-style: "gnu"    c-file-style: "gnu"

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

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