/[guile]/guile/guile-core/libguile/threads.c
ViewVC logotype

Diff of /guile/guile-core/libguile/threads.c

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

revision 1.30 by mvo, Sun Nov 10 22:04:26 2002 UTC revision 1.31 by mvo, Mon Dec 2 01:00:41 2002 UTC
# Line 1  Line 1 
1  /*      Copyright (C) 1995, 1996, 1997, 1998, 2000, 2002 Free Software Foundation, Inc.  /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002 Free Software Foundation, Inc.
2   *   *
3   * This program is free software; you can redistribute it and/or modify   * This program is free software; you can redistribute it and/or modify
4   * it under the terms of the GNU General Public License as published by   * it under the terms of the GNU General Public License as published by
# Line 42  Line 42 
42    
43    
44    
45  /* This file does some pretty hairy #inclusion.  It probably seemed  /* This file implements nice Scheme level threads on top of the gastly
46     like a good idea at the time, but it doesn't now.  Here's the     C level threads.
    structure, edited for relevance (!), last I checked:  
   
       threads.c:  
         threads.h  
           coop-defs.h  
             iselect.h  
         coop-threads.c  
           coop-threads.h  
             coop-defs.h*  
             ../qt/qt.h  
           coop.c  
             <qt.h>  
   
     * second #inclusion  
47  */  */
48    
49  #include <errno.h>  #include <unistd.h>
50    #include <stdio.h>
51    #include <assert.h>
52    #include <sys/time.h>
53    
54  #include "libguile/_scm.h"  #include "libguile/_scm.h"
55    #include "libguile/validate.h"
56    #include "libguile/root.h"
57    #include "libguile/eval.h"
58    #include "libguile/async.h"
59    #include "libguile/ports.h"
60    #include "libguile/threads.h"
61  #include "libguile/dynwind.h"  #include "libguile/dynwind.h"
62  #include "libguile/smob.h"  #include "libguile/iselect.h"
63    
64  #include "libguile/threads.h"  /*** Queues */
65    
66    static SCM
67    make_queue ()
68    {
69      return scm_cons (SCM_EOL, SCM_EOL);
70    }
71    
72  scm_t_bits scm_tc16_thread;  static SCM
73  scm_t_bits scm_tc16_mutex;  enqueue (SCM q, SCM t)
74  scm_t_bits scm_tc16_condvar;  {
75      SCM c = scm_cons (t, SCM_EOL);
76      if (SCM_NULLP (SCM_CDR (q)))
77        SCM_SETCDR (q, c);
78      else
79        SCM_SETCDR (SCM_CAR (q), c);
80      SCM_SETCAR (q, c);
81      return c;
82    }
83    
84    static void
85  /* Scheme-visible thread functions. */  remqueue (SCM q, SCM c)
86    {
87      SCM p, prev = q;
88      for (p = SCM_CDR (q); !SCM_NULLP (p); p = SCM_CDR (p))
89        {
90          if (SCM_EQ_P (p, c))
91            {
92              if (SCM_EQ_P (c, SCM_CAR (q)))
93                SCM_SETCAR (q, SCM_CDR (c));
94              SCM_SETCDR (prev, SCM_CDR (c));
95              return;
96            }
97          prev = p;
98        }
99      abort ();
100    }
101    
102  #ifdef USE_COOP_THREADS  static SCM
103  SCM_REGISTER_PROC(s_single_thread_p, "single-active-thread?", 0, 0, 0, scm_single_thread_p);  dequeue (SCM q)
104    {
105      SCM c = SCM_CDR (q);
106      if (SCM_NULLP (c))
107        return SCM_BOOL_F;
108      else
109        {
110          SCM_SETCDR (q, SCM_CDR (c));
111          if (SCM_NULLP (SCM_CDR (q)))
112            SCM_SETCAR (q, SCM_EOL);
113          return SCM_CAR (c);
114        }
115    }
116    
117    
118    /*** Threads */
119    
120    typedef struct scm_thread {
121      
122      /* Blocking.
123       */
124      scm_t_cond sleep_cond;
125      struct scm_thread *next_waiting;
126    
127      scm_root_state *root;
128      SCM handle;
129      scm_t_thread thread;
130      SCM result;
131      int exited;
132    
133      SCM joining_threads;
134    
135      /* For keeping track of the stack and registers. */
136      SCM_STACKITEM *base;
137      SCM_STACKITEM *top;
138      jmp_buf regs;
139    
140    } scm_thread;
141    
142    static SCM
143    make_thread (SCM creation_protects)
144    {
145      SCM z;
146      scm_thread *t;
147      z = scm_make_smob (scm_tc16_thread);
148      t = SCM_THREAD_DATA (z);
149      t->handle = z;
150      t->result = creation_protects;
151      t->base = NULL;
152      t->joining_threads = make_queue ();
153      scm_cond_init (&t->sleep_cond);
154      t->exited = 0;
155      return z;
156    }
157    
158    static void
159    init_thread_creator (SCM thread, scm_t_thread th, scm_root_state *r)
160    {
161      scm_thread *t = SCM_THREAD_DATA(thread);
162      t->root = r;
163      t->thread = th;
164    #ifdef DEBUG
165      // fprintf (stderr, "%ld created %ld\n", pthread_self (), th);
166  #endif  #endif
167    }
168    
169    static void
170    init_thread_creatant (SCM thread, SCM_STACKITEM *base)
171    {
172      scm_thread *t = SCM_THREAD_DATA(thread);
173      t->base = base;
174      t->top = NULL;
175    }
176    
177  /* GJB:FIXME:DOC: SCM_REGISTER_PROC needs to permit a docstring,  static SCM
178     or these need to move into the file where the proc is defined. */  thread_mark (SCM obj)
179    {
180      scm_thread *t = SCM_THREAD_DATA (obj);
181      scm_gc_mark (t->result);
182      scm_gc_mark (t->joining_threads);
183      return t->root->handle;
184    }
185    
186    static int
187    thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
188    {
189      scm_thread *t = SCM_THREAD_DATA (exp);
190      scm_puts ("#<thread ", port);
191      scm_intprint ((unsigned long)t, 16, port);
192      scm_putc ('>', port);
193      return 1;
194    }
195    
196  SCM_REGISTER_PROC(s_yield, "yield", 0, 0, 0, scm_yield);  static size_t
197  /* If one or more threads are waiting to execute, calling yield forces an  thread_free (SCM obj)
198  immediate context switch to one of them. Otherwise, yield has no effect.  {
199      scm_thread *t = SCM_THREAD_DATA (obj);
200      if (!t->exited)
201        abort ();
202      scm_gc_free (t, sizeof (*t), "thread");
203      return 0;
204    }
205    
206    /*** Fair mutexes */
207    
208    /* C level mutexes (such as POSIX mutexes) are not necessarily fair
209       but since we'd like to use a mutex for scheduling, we build a fair
210       one on top of the C one.
211  */  */
212    
213  SCM_REGISTER_PROC(s_call_with_new_thread, "call-with-new-thread", 0, 0, 1, scm_call_with_new_thread);  typedef struct fair_mutex {
214  /* Evaluate @var{(thunk)} in a new thread, and new dynamic context,    scm_t_mutex lock;
215  returning a new thread object representing the thread.    scm_thread *owner;
216      scm_thread *next_waiting, *last_waiting;
217  If an error occurs during evaluation, call error-thunk, passing it an  } fair_mutex;
 error code describing the condition.  [Error codes are currently  
 meaningless integers.  In the future, real values will be specified.]  
 If this happens, the error-thunk is called outside the scope of the new  
 root -- it is called in the same dynamic context in which  
 with-new-thread was evaluated, but not in the callers thread.  
218    
219  All the evaluation rules for dynamic roots apply to threads.  static void
220    fair_mutex_init (fair_mutex *m)
221    {
222      scm_mutex_init (&m->lock);
223      m->owner = NULL;
224      m->next_waiting = NULL;
225      m->last_waiting = NULL;
226    }
227    
228    static void
229    fair_mutex_lock_1 (fair_mutex *m, scm_thread *t)
230    {
231      if (m->owner == NULL)
232        m->owner = t;
233      else
234        {
235          t->next_waiting = NULL;
236          if (m->last_waiting)
237            m->last_waiting->next_waiting = t;
238          else
239            m->next_waiting = t;
240          m->last_waiting = t;
241          do
242            {
243              int err;
244              err = scm_cond_wait (&t->sleep_cond, &m->lock);
245              assert (err == 0);
246            }
247          while (m->owner != t);
248          assert (m->next_waiting == t);
249          m->next_waiting = t->next_waiting;
250          if (m->next_waiting == NULL)
251            m->last_waiting = NULL;
252        }
253      scm_mutex_unlock (&m->lock);
254    }
255    
256    static void
257    fair_mutex_lock (fair_mutex *m, scm_thread *t)
258    {
259      scm_mutex_lock (&m->lock);
260      fair_mutex_lock_1 (m, t);
261    }
262    
263    static void
264    fair_mutex_unlock_1 (fair_mutex *m)
265    {
266      scm_thread *t;
267      scm_mutex_lock (&m->lock);
268      // fprintf (stderr, "%ld unlocking\n", m->owner->pthread);
269      if ((t = m->next_waiting) != NULL)
270        {
271          m->owner = t;
272          scm_cond_signal (&t->sleep_cond);
273        }
274      else
275        m->owner = NULL;
276      // fprintf (stderr, "%ld unlocked\n", pthread_self ());
277    }
278    
279    static void
280    fair_mutex_unlock (fair_mutex *m)
281    {
282      fair_mutex_unlock_1 (m);
283      scm_mutex_unlock (&m->lock);
284    }
285    
286    /*  Temporarily give up the mutex.  This function makes sure that we
287        are on the wait queue before starting the next thread.  Otherwise
288        the next thread might preempt us and we will have a hard time
289        getting on the wait queue.
290  */  */
291    static void
292    fair_mutex_yield (fair_mutex *m)
293    {
294      scm_thread *self = m->owner;
295      fair_mutex_unlock_1 (m);
296      fair_mutex_lock_1 (m, self);
297    }
298    
299  SCM_REGISTER_PROC(s_current_thread, "current-thread", 0, 0, 0, scm_current_thread);  static int
300  SCM_REGISTER_PROC(s_all_thread, "all-threads", 0, 0, 0, scm_all_threads);  fair_cond_wait (scm_t_cond *c, fair_mutex *m)
301    {
302      scm_thread *t = m->owner;
303      int err;
304      fair_mutex_unlock_1 (m);
305      err = scm_cond_wait (c, &m->lock);
306      fair_mutex_lock_1 (m, t);
307      return err;
308    }
309    
310  SCM_REGISTER_PROC(s_join_thread, "join-thread", 1, 0, 0, scm_join_thread);  static int
311  /* Suspend execution of the calling thread until the target @var{thread}  fair_cond_timedwait (scm_t_cond *c, fair_mutex *m, struct timespec *at)
312  terminates, unless the target @var{thread} has already terminated.  {
313      int err;
314      scm_thread *t = m->owner;
315      fair_mutex_unlock_1 (m);
316      err = scm_cond_timedwait (c, &m->lock, at);  /* XXX - signals? */
317      fair_mutex_lock_1 (m, t);
318      return err;
319    }
320    
321    /*** Scheduling */
322    
323    /* When a thread wants to execute Guile functions, it locks the
324       guile_mutex.
325  */  */
326    
327  SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0,  static fair_mutex guile_mutex;
328    
329    static SCM cur_thread;
330    void *scm_i_thread_data;
331    
332    void
333    scm_i_set_thread_data (void *data)
334    {
335      scm_thread *t = SCM_THREAD_DATA (cur_thread);
336      scm_i_thread_data = data;
337      t->root = (scm_root_state *)data;
338    }
339      
340    static void
341    resume (scm_thread *t)
342    {
343      cur_thread = t->handle;
344      scm_i_thread_data = t->root;
345      t->top = NULL;
346    }
347    
348    static void
349    enter_guile (scm_thread *t)
350    {
351      fair_mutex_lock (&guile_mutex, t);
352      resume (t);
353    }
354    
355    static scm_thread *
356    suspend ()
357    {
358      SCM cur = cur_thread;
359      scm_thread *c = SCM_THREAD_DATA (cur);
360    
361      /* record top of stack for the GC */
362      c->top = (SCM_STACKITEM *)&c;
363      /* save registers. */
364      SCM_FLUSH_REGISTER_WINDOWS;
365      setjmp (c->regs);
366    
367      return c;
368    }
369    
370    static scm_thread *
371    leave_guile ()
372    {
373      scm_thread *c = suspend ();
374      fair_mutex_unlock (&guile_mutex);
375      return c;
376    }
377    
378    int scm_i_switch_counter;
379    
380    SCM
381    scm_yield ()
382    {
383      /* Testing guile_mutex.next_waiting without locking guile_mutex.lock
384         is OK since the outcome is not critical.  Even when it changes
385         after the test, we do the right thing.
386      */
387      if (guile_mutex.next_waiting)
388        {
389          scm_thread *t = suspend ();
390          fair_mutex_yield (&guile_mutex);
391          resume (t);
392        }
393      return SCM_BOOL_T;
394    }
395    
396    /* Put the current thread to sleep until it is explicitely unblocked.
397     */
398    static int
399    block ()
400    {
401      int err;
402      scm_thread *t = suspend ();
403      err = fair_cond_wait (&t->sleep_cond, &guile_mutex);
404      resume (t);
405      return err;
406    }
407    
408    /* Put the current thread to sleep until it is explicitely unblocked
409       or until a signal arrives or until time AT (absolute time) is
410       reached.  Return 0 when it has been unblocked; errno otherwise.
411     */
412    static int
413    timed_block (struct timespec *at)
414    {
415      int err;
416      scm_thread *t = suspend ();
417      err = fair_cond_timedwait (&t->sleep_cond, &guile_mutex, at);
418      resume (t);
419      return err;
420    }
421    
422    /* Unblock a sleeping thread.
423     */
424    static void
425    unblock (scm_thread *t)
426    {
427      scm_cond_signal (&t->sleep_cond);
428    }
429    
430    /*** Thread creation */
431    
432    static SCM all_threads;
433    static int thread_count;
434    
435    typedef struct launch_data {
436      SCM thread;
437      SCM rootcont;
438      scm_t_catch_body body;
439      void *body_data;
440      scm_t_catch_handler handler;
441      void *handler_data;
442    } launch_data;
443    
444    static SCM
445    body_bootstrip (launch_data* data)
446    {
447      /* First save the new root continuation */
448      data->rootcont = scm_root->rootcont;
449      return (data->body) (data->body_data);
450    }
451    
452    static SCM
453    handler_bootstrip (launch_data* data, SCM tag, SCM throw_args)
454    {
455      scm_root->rootcont = data->rootcont;
456      return (data->handler) (data->handler_data, tag, throw_args);
457    }
458    
459    static void
460    really_launch (SCM_STACKITEM *base, launch_data *data)
461    {
462      SCM thread = data->thread;
463      scm_thread *t = SCM_THREAD_DATA (thread);
464      init_thread_creatant (thread, base);
465      enter_guile (t);
466    
467      data->rootcont = SCM_BOOL_F;
468      t->result =
469        scm_internal_cwdr ((scm_t_catch_body) body_bootstrip,
470                           data,
471                           (scm_t_catch_handler) handler_bootstrip,
472                           data, base);
473      free (data);
474    
475      scm_thread_detach (t->thread);
476      all_threads = scm_delq (thread, all_threads);
477      t->exited = 1;
478      thread_count--;
479      leave_guile ();
480    }
481    
482    static void
483    launch_thread (void *p)
484    {
485      really_launch ((SCM_STACKITEM *)&p, (launch_data *)p);
486    }
487    
488    static SCM
489    create_thread (scm_t_catch_body body, void *body_data,
490                   scm_t_catch_handler handler, void *handler_data,
491                   SCM protects)
492    {
493      SCM thread;
494    
495      /* Make new thread.  The first thing the new thread will do is to
496         lock guile_mutex.  Thus, we can safely complete its
497         initialization after creating it.  While the new thread starts,
498         all its data is protected via all_threads.
499       */
500    
501      {
502        scm_t_thread th;
503        SCM root, old_winds;
504        launch_data *data;
505        int err;
506    
507        /* Unwind wind chain. */
508        old_winds = scm_dynwinds;
509        scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
510    
511        /* Allocate thread locals. */
512        root = scm_make_root (scm_root->handle);
513        data = scm_malloc (sizeof (launch_data));
514    
515        /* Make thread. */
516        thread = make_thread (protects);
517        data->thread = thread;
518        data->body = body;
519        data->body_data = body_data;
520        data->handler = handler;
521        data->handler_data = handler_data;
522        err = scm_thread_create (&th, launch_thread, (void *) data);
523        if (err == 0)
524          {
525            init_thread_creator (thread, th, SCM_ROOT_STATE (root));
526            all_threads = scm_cons (thread, all_threads);
527            thread_count++;
528          }
529        else
530          ((scm_thread *)SCM_THREAD_DATA(thread))->exited = 1;
531    
532        /* Return to old dynamic context. */
533        scm_dowinds (old_winds, - scm_ilength (old_winds));
534    
535        if (err)
536          {
537            errno = err;
538            scm_syserror ("create-thread");
539          }
540      }
541    
542      return thread;
543    }
544    
545    SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 2, 0, 0,
546                (SCM thunk, SCM handler),
547    "Evaluate @var{(thunk)} in a new thread, and new dynamic context, "
548    "returning a new thread object representing the thread. "
549    "If an error occurs during evaluation, call error-thunk, passing it an "
550    "error code describing the condition. "
551    "If this happens, the error-thunk is called outside the scope of the new "
552    "root -- it is called in the same dynamic context in which "
553    "with-new-thread was evaluated, but not in the callers thread. "
554    "All the evaluation rules for dynamic roots apply to threads.")
555    #define FUNC_NAME s_scm_call_with_new_thread
556    {
557      SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), thunk, SCM_ARG1, FUNC_NAME);
558      SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)), handler, SCM_ARG2,
559                  FUNC_NAME);
560    
561      return create_thread ((scm_t_catch_body) scm_call_0, thunk,
562                            (scm_t_catch_handler) scm_apply_1, handler,
563                            scm_cons (thunk, handler));
564    }
565    #undef FUNC_NAME
566    
567    SCM
568    scm_spawn_thread (scm_t_catch_body body, void *body_data,
569                      scm_t_catch_handler handler, void *handler_data)
570    {
571      return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F);
572    }
573    
574    SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0,
575              (SCM thread),              (SCM thread),
576              "Return @code{#t} iff @var{thread} has exited.\n")  "Suspend execution of the calling thread until the target @var{thread} "
577  #define FUNC_NAME s_scm_thread_exited_p  "terminates, unless the target @var{thread} has already terminated. ")
578    #define FUNC_NAME s_scm_join_thread
579  {  {
580    return SCM_BOOL (scm_c_thread_exited_p (thread));    scm_thread *t;
581      SCM res;
582    
583      SCM_VALIDATE_THREAD (1, thread);
584      if (SCM_EQ_P (cur_thread, thread))
585        SCM_MISC_ERROR ("can not join the current thread", SCM_EOL);
586    
587      t = SCM_THREAD_DATA (thread);
588      if (!t->exited)
589        {
590          scm_thread *c = leave_guile ();
591          scm_thread_join (t->thread);
592          enter_guile (c);
593        }
594      res = t->result;
595      t->result = SCM_BOOL_F;
596      return res;
597  }  }
598  #undef FUNC_NAME  #undef FUNC_NAME
599    
600  SCM_REGISTER_PROC(s_make_mutex, "make-mutex", 0, 0, 0, scm_make_mutex);  /*** Mutexes */
 /* Create a new mutex object. */  
601    
602  SCM_REGISTER_PROC(s_lock_mutex, "lock-mutex", 1, 0, 0, scm_lock_mutex);  /* We implement our own mutex type since we want them to be 'fair', we
603  /* Lock @var{mutex}. If the mutex is already locked, the calling thread     want to do fancy things while waiting for them (like running
604  blocks until the mutex becomes available. The function returns when     asyncs) and we want to support waiting on many things at once.
605  the calling thread owns the lock on @var{mutex}. */     Also, we might add things that are nice for debugging.
606    */
607    
608  SCM_REGISTER_PROC(s_try_mutex, "try-mutex", 1, 0, 0, scm_try_mutex);  typedef struct scm_mutex {
609  /* Try to lock @var{mutex}. If the mutex is already locked by someone    /* the thread currently owning the mutex, or SCM_BOOL_F. */
610  else, return @code{#f}.  Else lock the mutex and return @code{#t}. */    SCM owner;
611      /* how much the owner owns us. */
612      int level;
613      /* the threads waiting for this mutex. */
614      SCM waiting;
615    } scm_mutex;
616    
617  SCM_REGISTER_PROC(s_unlock_mutex, "unlock-mutex", 1, 0, 0, scm_unlock_mutex);  static SCM
618  /* Unlocks @var{mutex} if the calling thread owns the lock on @var{mutex}.  mutex_mark (SCM mx)
619  Calling unlock-mutex on a mutex not owned by the current thread results  {
620  in undefined behaviour. Once a mutex has been unlocked, one thread    scm_mutex *m = SCM_MUTEX_DATA (mx);
621  blocked on @var{mutex} is awakened and grabs the mutex lock. */    scm_gc_mark (m->owner);
622      return m->waiting;
623    }
624    
625  SCM_REGISTER_PROC(s_make_condition_variable, "make-condition-variable", 0, 0, 0, scm_make_condition_variable);  SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0,
626                (void),
627                "Create a new mutex object. ")
628    #define FUNC_NAME s_scm_make_mutex
629    {
630      SCM mx = scm_make_smob (scm_tc16_mutex);
631      scm_mutex *m = SCM_MUTEX_DATA (mx);
632      m->owner = SCM_BOOL_F;
633      m->level = 0;
634      m->waiting = make_queue ();
635      return mx;
636    }
637    #undef FUNC_NAME
638    
639    SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0,
640                (SCM mx),
641    "Lock @var{mutex}. If the mutex is already locked, the calling thread "
642    "blocks until the mutex becomes available. The function returns when "
643    "the calling thread owns the lock on @var{mutex}.  Locking a mutex that "
644    "a thread already owns will succeed right away and will not block the "
645    "thread.  That is, Guile's mutexes are @emph{recursive}. ")
646    #define FUNC_NAME s_scm_lock_mutex
647    {
648      scm_mutex *m;
649      SCM_VALIDATE_MUTEX (1, mx);
650      m = SCM_MUTEX_DATA (mx);
651    
652      if (m->owner == SCM_BOOL_F)
653        m->owner = cur_thread;
654      else if (m->owner == cur_thread)
655        m->level++;
656      else
657        {
658          while (1)
659            {
660              SCM c = enqueue (m->waiting, cur_thread);
661              int err = block ();
662              if (m->owner == cur_thread)
663                return SCM_BOOL_T;
664              remqueue (m->waiting, c);
665              if (err)
666                {
667                  errno = err;
668                  scm_syserror (FUNC_NAME);
669                }
670              SCM_ASYNC_TICK;
671            }
672        }
673      return SCM_BOOL_T;
674    }
675    #undef FUNC_NAME
676    
677  SCM_REGISTER_PROC(s_wait_condition_variable, "wait-condition-variable", 2, 1, 0, scm_timed_wait_condition_variable);  SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0,
678                (SCM mx),
679    "Try to lock @var{mutex}. If the mutex is already locked by someone "
680    "else, return @code{#f}.  Else lock the mutex and return @code{#t}. ")
681    #define FUNC_NAME s_scm_try_mutex
682    {
683      scm_mutex *m;
684      SCM_VALIDATE_MUTEX (1, mx);
685      m = SCM_MUTEX_DATA (mx);
686    
687      if (m->owner == SCM_BOOL_F)
688        m->owner = cur_thread;
689      else if (m->owner == cur_thread)
690        m->level++;
691      else
692        return SCM_BOOL_F;
693      return SCM_BOOL_T;
694    }
695    #undef FUNC_NAME
696    
697  SCM_REGISTER_PROC(s_signal_condition_variable, "signal-condition-variable", 1, 0, 0, scm_signal_condition_variable);  SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0,
698                (SCM mx),
699    "Unlocks @var{mutex} if the calling thread owns the lock on "
700    "@var{mutex}.  Calling unlock-mutex on a mutex not owned by the current "
701    "thread results in undefined behaviour. Once a mutex has been unlocked, "
702    "one thread blocked on @var{mutex} is awakened and grabs the mutex "
703    "lock.  Every call to @code{lock-mutex} by this thread must be matched "
704    "with a call to @code{unlock-mutex}.  Only the last call to "
705    "@code{unlock-mutex} will actually unlock the mutex. ")
706    #define FUNC_NAME s_scm_unlock_mutex
707    {
708      scm_mutex *m;
709      SCM_VALIDATE_MUTEX (1, mx);
710      m = SCM_MUTEX_DATA (mx);
711    
712      if (m->owner != cur_thread)
713        {
714          if (m->owner == SCM_BOOL_F)
715            SCM_MISC_ERROR ("mutex not locked", SCM_EOL);
716          else
717            SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL);
718        }
719      else if (m->level > 0)
720        m->level--;
721      else
722        {
723          SCM next = dequeue (m->waiting);
724          if (!SCM_FALSEP (next))
725            {
726              m->owner = next;
727              unblock (SCM_THREAD_DATA (next));
728              scm_yield ();
729            }
730          else
731            m->owner = SCM_BOOL_F;
732        }
733      return SCM_BOOL_T;
734    }
735    #undef FUNC_NAME
736    
737  SCM_REGISTER_PROC(s_broadcast_condition_variable, "broadcast-condition-variable", 1, 0, 0, scm_broadcast_condition_variable);  /*** Condition variables */
738    
739    /* Like mutexes, we implement our own condition variables using the
740       primitives above.
741    */
742    
743    /* yeah, we don't need a structure for this, but more things (like a
744       name) will likely follow... */
745    
746    typedef struct scm_cond {
747      /* the threads waiting for this condition. */
748      SCM waiting;
749    } scm_cond;
750    
751    static SCM
752    cond_mark (SCM cv)
753    {
754      scm_cond *c = SCM_CONDVAR_DATA (cv);
755      return c->waiting;
756    }
757    
758    SCM_DEFINE (scm_make_condition_variable, "make-condition-variable", 0, 0, 0,
759                (void),
760                "Make a new condition variable.")
761    #define FUNC_NAME s_scm_make_condition_variable
762    {
763      SCM cv = scm_make_smob (scm_tc16_condvar);
764      scm_cond *c = SCM_CONDVAR_DATA (cv);
765      c->waiting = make_queue ();
766      return cv;
767    }
768    #undef FUNC_NAME
769    
770    SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, 0,
771                (SCM cv, SCM mx, SCM t),
772    "Wait until @var{cond-var} has been signalled.  While waiting, "
773    "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
774    "is locked again when this function returns.  When @var{time} is given, "
775    "it specifies a point in time where the waiting should be aborted.  It "
776    "can be either a integer as returned by @code{current-time} or a pair "
777    "as returned by @code{gettimeofday}.  When the waiting is aborted the "
778    "mutex is locked and @code{#f} is returned.  When the condition "
779    "variable is in fact signalled, the mutex is also locked and @code{#t} "
780    "is returned. ")
781    #define FUNC_NAME s_scm_timed_wait_condition_variable
782    {
783      scm_cond *c;
784      struct timespec waittime;
785      int err;
786    
787      SCM_VALIDATE_CONDVAR (1, cv);
788      SCM_VALIDATE_MUTEX (2, mx);
789    
790      if (!SCM_UNBNDP (t))
791        {
792          if (SCM_CONSP (t))
793            {
794              SCM_VALIDATE_UINT_COPY (3, SCM_CAR(t), waittime.tv_sec);
795              SCM_VALIDATE_UINT_COPY (3, SCM_CDR(t), waittime.tv_nsec);
796              waittime.tv_nsec *= 1000;
797            }
798          else
799            {
800              SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec);
801              waittime.tv_nsec = 0;
802            }
803        }
804    
805      c = SCM_CONDVAR_DATA (cv);
806    
807      while (1)
808        {
809          enqueue (c->waiting, cur_thread);
810          scm_unlock_mutex (mx);
811          if (SCM_UNBNDP (t))
812            err = block ();
813          else
814            err = timed_block (&waittime);
815          scm_lock_mutex (mx);
816          if (err)
817            {
818              errno = err;
819              scm_syserror (FUNC_NAME);
820            }
821          /* XXX - check whether we have been signalled. */
822          break;
823        }
824      return SCM_BOOL (err == 0);
825    }
826    #undef FUNC_NAME
827    
828  SCM  SCM
829  scm_wait_condition_variable (SCM c, SCM m)  scm_wait_condition_variable (SCM c, SCM m)
# Line 152  scm_wait_condition_variable (SCM c, SCM Line 831  scm_wait_condition_variable (SCM c, SCM
831    return scm_timed_wait_condition_variable (c, m, SCM_UNDEFINED);    return scm_timed_wait_condition_variable (c, m, SCM_UNDEFINED);
832  }  }
833    
834    SCM_DEFINE (scm_signal_condition_variable, "signal-condition-variable", 1, 0, 0,
835                (SCM cv),
836  #ifdef USE_COOP_THREADS              "Wake up one thread that is waiting for @var{cv}")
837  #include "libguile/coop-threads.c"  #define FUNC_NAME s_scm_signal_condition_variable
838  #else  {
839  #ifdef USE_COPT_THREADS    SCM th;
840  #include "libguile/coop-pthreads.c"    scm_cond *c;
 #else  
 #include "libguile/null-threads.c"  
 #endif  
 #endif  
   
   
841    
842  #if (SCM_ENABLE_DEPRECATED == 1)    SCM_VALIDATE_CONDVAR (1, cv);
843    
844  int    c = SCM_CONDVAR_DATA (cv);
845  scm_mutex_init (scm_t_mutex *m)    if (!SCM_FALSEP (th = dequeue (c->waiting)))
846  {      unblock (SCM_THREAD_DATA (th));
847    scm_gc_protect_object (m->m = scm_make_mutex ());    return SCM_BOOL_T;
   return 0;  
848  }  }
849    #undef FUNC_NAME
850    
851  int  SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1, 0, 0,
852  scm_mutex_lock (scm_t_mutex *m)              (SCM cv),
853                "Wake up all threads that are waiting for @var{cv}. ")
854    #define FUNC_NAME s_scm_broadcast_condition_variable
855  {  {
856    scm_lock_mutex (m->m);    SCM th;
857    return 0;    scm_cond *c;
858    
859      SCM_VALIDATE_CONDVAR (1, cv);
860    
861      c = SCM_CONDVAR_DATA (cv);
862      while (!SCM_FALSEP (th = dequeue (c->waiting)))
863        unblock (SCM_THREAD_DATA (th));
864      return SCM_BOOL_T;
865  }  }
866    #undef FUNC_NAME
867    
868  int  /*** Marking stacks */
869  scm_mutex_trylock (scm_t_mutex *m)  
870    /* XXX - what to do with this?  Do we need to handle this for blocked
871       threads as well?
872    */
873    #ifdef __ia64__
874    # define SCM_MARK_BACKING_STORE() do {                                \
875        ucontext_t ctx;                                                   \
876        SCM_STACKITEM * top, * bot;                                       \
877        getcontext (&ctx);                                                \
878        scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext,           \
879          ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
880           / sizeof (SCM_STACKITEM)));                                    \
881        bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base;  \
882        top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp;                \
883        scm_mark_locations (bot, top - bot); } while (0)
884    #else
885    # define SCM_MARK_BACKING_STORE()
886    #endif
887    
888    void
889    scm_threads_mark_stacks (void)
890  {  {
891    return SCM_FALSEP (scm_try_mutex (m->m))? EBUSY : 0;    volatile SCM c;
892      for (c = all_threads; !SCM_NULLP (c); c = SCM_CDR (c))
893        {
894          scm_thread *t = SCM_THREAD_DATA (SCM_CAR (c));
895          if (t->base == NULL)
896            {
897              /* Not fully initialized yet. */
898              continue;
899            }
900          if (t->top == NULL)
901            {
902              /* Active thread */
903              /* stack_len is long rather than sizet in order to guarantee
904                 that &stack_len is long aligned */
905    #ifdef STACK_GROWS_UP
906              long stack_len = ((SCM_STACKITEM *) (&t) -
907                                (SCM_STACKITEM *) thread->base);
908              
909              /* Protect from the C stack.  This must be the first marking
910               * done because it provides information about what objects
911               * are "in-use" by the C code.   "in-use" objects are  those
912               * for which the information about length and base address must
913               * remain usable.   This requirement is stricter than a liveness
914               * requirement -- in particular, it constrains the implementation
915               * of scm_resizuve.
916               */
917              SCM_FLUSH_REGISTER_WINDOWS;
918              /* This assumes that all registers are saved into the jmp_buf */
919              setjmp (scm_save_regs_gc_mark);
920              scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
921                                  ((size_t) sizeof scm_save_regs_gc_mark
922                                   / sizeof (SCM_STACKITEM)));
923              
924              scm_mark_locations (((size_t) t->base,
925                                   (sizet) stack_len));
926    #else
927              long stack_len = ((SCM_STACKITEM *) t->base -
928                                (SCM_STACKITEM *) (&t));
929              
930              /* Protect from the C stack.  This must be the first marking
931               * done because it provides information about what objects
932               * are "in-use" by the C code.   "in-use" objects are  those
933               * for which the information about length and base address must
934               * remain usable.   This requirement is stricter than a liveness
935               * requirement -- in particular, it constrains the implementation
936               * of scm_resizuve.
937               */
938              SCM_FLUSH_REGISTER_WINDOWS;
939              /* This assumes that all registers are saved into the jmp_buf */
940              setjmp (scm_save_regs_gc_mark);
941              scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
942                                  ((size_t) sizeof scm_save_regs_gc_mark
943                                   / sizeof (SCM_STACKITEM)));
944              
945              scm_mark_locations ((SCM_STACKITEM *) &t,
946                                  stack_len);
947    #endif
948            }
949          else
950            {
951              /* Suspended thread */
952    #ifdef STACK_GROWS_UP
953              long stack_len = t->top - t->base;
954              scm_mark_locations (t->base, stack_len);
955    #else
956              long stack_len = t->base - t->top;
957              scm_mark_locations (t->top, stack_len);
958    #endif
959              scm_mark_locations ((SCM_STACKITEM *) t->regs,
960                                  ((size_t) sizeof(t->regs)
961                                   / sizeof (SCM_STACKITEM)));
962            }
963        }
964  }  }
965    
966    /*** Select */
967    
968  int  int
969  scm_mutex_unlock (scm_t_mutex *m)  scm_internal_select (int nfds,
970                         SELECT_TYPE *readfds,
971                         SELECT_TYPE *writefds,
972                         SELECT_TYPE *exceptfds,
973                         struct timeval *timeout)
974  {  {
975    scm_unlock_mutex (m->m);    int res, eno;
976    return 0;    scm_thread *c = leave_guile ();
977      res = scm_thread_select (nfds, readfds, writefds, exceptfds, timeout);
978      eno = errno;
979      enter_guile (c);
980      SCM_ASYNC_TICK;
981      errno = eno;
982      return res;
983  }  }
984    
985  int  unsigned long
986  scm_mutex_destroy (scm_t_mutex *m)  scm_thread_usleep (unsigned long usecs)
987  {  {
988    scm_gc_unprotect_object (m->m);    struct timeval tv;
989    return 0;    tv.tv_usec = usecs % 1000000;
990      tv.tv_sec = usecs / 1000000;
991      scm_internal_select (0, NULL, NULL, NULL, &tv);
992      return tv.tv_usec + tv.tv_sec*1000000;
993  }  }
994    
995  SCM_API int  unsigned long
996  scm_cond_init (scm_t_cond *c, int *cattr)  scm_thread_sleep (unsigned long secs)
997  {  {
998    scm_gc_protect_object (c->c = scm_make_condition_variable ());    struct timeval tv;
999    return 0;    tv.tv_usec = 0;
1000      tv.tv_sec = secs;
1001      scm_internal_select (0, NULL, NULL, NULL, &tv);
1002      return tv.tv_sec;
1003  }  }
1004    
1005  int  /*** Misc */
1006  scm_cond_wait (scm_t_cond *c, scm_t_mutex *m)  
1007    SCM_DEFINE (scm_current_thread, "current-thread", 0, 0, 0,
1008                (void),
1009                "Return the thread that called this function.")
1010    #define FUNC_NAME s_scm_current_thread
1011  {  {
1012    scm_wait_condition_variable (c->c, m->m);    return cur_thread;
   return 0;  
1013  }  }
1014    #undef FUNC_NAME
1015    
1016  int  SCM_DEFINE (scm_all_threads, "all-threads", 0, 0, 0,
1017  scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m,              (void),
1018                      const struct timespec *t)              "Return a list of all threads.")
1019    #define FUNC_NAME s_all_threads
1020  {  {
1021    return !SCM_FALSEP (scm_timed_wait_condition_variable (    return all_threads;
     c->c, m->m, scm_cons (scm_long2num (t->tv_sec),  
                           scm_long2num (t->tv_nsec/1000))));  
1022  }  }
1023    #undef FUNC_NAME
1024    
1025  int  scm_root_state *
1026  scm_cond_signal (scm_t_cond *c)  scm_i_thread_root (SCM thread)
1027  {  {
1028    scm_signal_condition_variable (c->c);    return ((scm_thread *)SCM_THREAD_DATA (thread))->root;
   return 0;  
1029  }  }
1030    
1031  int  SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0,
1032  scm_cond_broadcast (scm_t_cond *c)              (SCM thread),
1033                "Return @code{#t} iff @var{thread} has exited.\n")
1034    #define FUNC_NAME s_scm_thread_exited_p
1035  {  {
1036    scm_broadcast_condition_variable (c->c);    return SCM_BOOL (scm_c_thread_exited_p (thread));
   return 0;  
1037  }  }
1038    #undef FUNC_NAME
1039    
1040  int  int
1041  scm_cond_destroy (scm_t_cond *c)  scm_c_thread_exited_p (SCM thread)
1042    #define FUNC_NAME  s_scm_thread_exited_p
1043  {  {
1044    scm_gc_unprotect_object (c->c);    scm_thread *t;
1045    return 0;    SCM_VALIDATE_THREAD (1, thread);
1046      t = SCM_THREAD_DATA (thread);
1047      return t->exited;
1048  }  }
1049    #undef FUNC_NAME
1050    
1051  #endif  /*** Initialization */
1052    
1053    scm_t_bits scm_tc16_thread;
1054    scm_t_bits scm_tc16_mutex;
1055    scm_t_bits scm_tc16_condvar;
1056    
1057  void  void
1058  scm_init_threads (SCM_STACKITEM *i)  scm_init_threads (SCM_STACKITEM *base)
1059  {  {
1060    /* Initialize implementation specific details of the threads support */    scm_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_thread));
1061    scm_threads_init (i);    scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_mutex));
1062      scm_tc16_condvar = scm_make_smob_type ("condition-variable",
1063                                             sizeof (scm_cond));
1064    
1065      scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT;
1066    
1067      fair_mutex_init (&guile_mutex);
1068    
1069      cur_thread = make_thread (SCM_BOOL_F);
1070      enter_guile (SCM_THREAD_DATA (cur_thread));
1071      /* root is set later from init.c */
1072      init_thread_creator (cur_thread, scm_thread_self(), NULL);
1073      init_thread_creatant (cur_thread, base);
1074    
1075      thread_count = 1;
1076      scm_gc_register_root (&all_threads);
1077      all_threads = scm_cons (cur_thread, SCM_EOL);
1078    
1079      scm_set_smob_mark (scm_tc16_thread, thread_mark);
1080      scm_set_smob_print (scm_tc16_thread, thread_print);
1081      scm_set_smob_free (scm_tc16_thread, thread_free);
1082    
1083      scm_set_smob_mark (scm_tc16_mutex, mutex_mark);
1084    
1085      scm_set_smob_mark (scm_tc16_condvar, cond_mark);
1086  }  }
1087    
1088  void  void
# Line 263  scm_init_thread_procs () Line 1091  scm_init_thread_procs ()
1091  #include "libguile/threads.x"  #include "libguile/threads.x"
1092  }  }
1093    
1094    /* XXX */
1095    
1096    void
1097    scm_init_iselect ()
1098    {
1099    }
1100    
1101  /*  /*
1102    Local Variables:    Local Variables:
1103    c-file-style: "gnu"    c-file-style: "gnu"
1104    End:    End:
1105  */  */
1106    

Legend:
Removed from v.1.30  
changed lines
  Added in v.1.31

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