mutex-pthreads.c 8.95 KB
Newer Older
eg's avatar
eg committed
1
/*
2
 * mutex-pthreads.c     -- Pthread Mutexes in Scheme
3
 *
4
 * Copyright © 2006-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
5 6
 *
 *
eg's avatar
eg committed
7 8 9 10
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
11
 *
eg's avatar
eg committed
12 13 14 15
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
16
 *
eg's avatar
eg committed
17 18
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
19
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
eg's avatar
eg committed
20
 * USA.
21
 *
eg's avatar
eg committed
22 23
 *           Author: Erick Gallesio [eg@essi.fr]
 *    Creation date:  2-Feb-2006 21:58 (eg)
24
 * Last file update: 21-Sep-2018 08:47 (eg)
eg's avatar
eg committed
25 26 27 28 29
 */

#include <unistd.h>
#include "stklos.h"
#include "vm.h"
30 31
#include "mutex-common.h"
#include "thread-common.h"
eg's avatar
eg committed
32 33 34 35


/* ====================================================================== *\
 *
36
 *                             M U T E X E S
37
 *
eg's avatar
eg committed
38 39
\* ====================================================================== */

40
static void mutex_finalizer(SCM mtx)
eg's avatar
eg committed
41 42 43 44 45
{
  pthread_mutex_destroy(&MUTEX_MYMUTEX(mtx));
  pthread_cond_destroy(&MUTEX_MYCONDV(mtx));
}

46

47
void STk_make_sys_mutex(SCM z)
eg's avatar
eg committed
48 49 50 51
{
  pthread_mutex_init(&MUTEX_MYMUTEX(z), NULL);
  pthread_cond_init(&MUTEX_MYCONDV(z), NULL);

52 53 54
#ifdef THREAD_FINALIZER_ISSUE
   STk_register_finalizer(z, mutex_finalizer);
#endif
eg's avatar
eg committed
55 56
}

eg's avatar
eg committed
57 58 59
/*
<doc EXT mutex-state
 * (mutex-state mutex)
60 61
 *
 * Returns information about the state of the |mutex|. The possible results
eg's avatar
eg committed
62 63 64 65
 * are:
 * ,(itemize
 *  (item [,(bold "thread T"): the mutex is in the locked/owned state and
 *     thread T is the owner of the mutex])
66
 *  (item [,(bold "symbol not-owned"): the mutex is in the locked/not-owned
eg's avatar
eg committed
67
 *     state])
68
 *  (item [,(bold "symbol abandoned"): the mutex is in the unlocked/abandoned
eg's avatar
eg committed
69
 *      state])
70
 *  (item [,(bold "symbol not-abandoned"): the mutex is in the
eg's avatar
eg committed
71 72 73
 *      unlocked/not-abandoned state]))
 * @lisp
 * (mutex-state (make-mutex))  =>  not-abandoned
74
 *
eg's avatar
eg committed
75 76 77 78 79 80 81 82 83
 * (define (thread-alive? thread)
 *   (let ((mutex (make-mutex)))
 *     (mutex-lock! mutex #f thread)
 *     (let ((state (mutex-state mutex)))
 *       (mutex-unlock! mutex) ; avoid space leak
 *       (eq? state thread))))
 * @end lisp
doc>
*/
eg's avatar
eg committed
84 85 86 87
DEFINE_PRIMITIVE("mutex-state", mutex_state, subr1, (SCM mtx))
{
  SCM res;

88
  if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
89

eg's avatar
eg committed
90 91
  pthread_mutex_lock(&MUTEX_MYMUTEX(mtx));

92
  if (MUTEX_LOCKED(mtx) &&
eg's avatar
eg committed
93 94 95 96 97 98
      (MUTEX_OWNER(mtx) != STk_false) &&
      (THREAD_STATE(MUTEX_OWNER(mtx)) == th_terminated)) {
    /* The thread which owns this mutex is terminated => Unlock the mutex */
    MUTEX_LOCKED(mtx) = FALSE;
  }

eg's avatar
eg committed
99
  if (MUTEX_LOCKED(mtx))
100
    res = (MUTEX_OWNER(mtx) == STk_false) ? STk_sym_not_owned : MUTEX_OWNER(mtx);
101
  else
102
    res = (MUTEX_OWNER(mtx) == STk_false) ? STk_sym_not_abandoned: STk_sym_abandoned;
103

eg's avatar
eg committed
104 105 106 107 108 109
  pthread_mutex_unlock(&MUTEX_MYMUTEX(mtx));

  return res;
}


eg's avatar
eg committed
110 111 112 113 114
/*
<doc EXT mutex-lock!
 * (mutex-lock! mutex)
 * (mutex-lock! mutex timeout)
 * (mutex-lock! mutex timeout thread)
115
 *
eg's avatar
eg committed
116
 * If the |mutex| is currently locked, the current thread waits until the
117 118
 * |mutex| is unlocked, or until the timeout is reached if |timeout| is supplied.
 * If the |timeout| is reached, |mutex-lock!| returns |#f|.
eg's avatar
eg committed
119
 * Otherwise, the state of the mutex is changed as follows:
120
 * ,(itemize
eg's avatar
eg committed
121 122 123
 *  (item [if thread is |#f| the mutex becomes locked/not-owned,])
 *  (item [otherwise, let T be thread (or the current thread if thread
 *         is not supplied),
124
 *         ,(itemize
eg's avatar
eg committed
125 126
 *           (item [if T is terminated the mutex becomes unlocked/abandoned,])
 *           (item [otherwise mutex becomes locked/owned with T as the owner.]))]))
127 128 129 130
 * @l
 * After changing the state of the mutex, an "abandoned mutex exception" is
 * raised if the mutex was unlocked/abandoned before the state change,
 * otherwise |mutex-lock!| returns |#t|.
eg's avatar
eg committed
131 132 133 134 135 136 137 138 139
 * @lisp
 * (define (sleep! timeout)
 *   ;; an alternate implementation of thread-sleep!
 *   (let ((m (make-mutex)))
 *   (mutex-lock! m #f #f)
 *   (mutex-lock! m timeout #f)))
 * @end lisp
doc>
*/
140 141 142 143 144
DEFINE_PRIMITIVE("%mutex-lock!", mutex_lock, subr3, (SCM mtx, SCM tm, SCM thread))
{
  struct timespec ts;
  SCM res = STk_true;

145
  if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
146 147
  if (!BOOLEANP(tm)) {
    double tmd = STk_verify_timeout(tm);
148 149 150 151 152
    ts.tv_sec  = (time_t) tmd;
    ts.tv_nsec = (suseconds_t) ((tmd - ts.tv_sec) * 1000000);
  }

  pthread_cleanup_push((void (*)(void*))mutex_finalizer, mtx);
153

154
  if (pthread_mutex_lock(&MUTEX_MYMUTEX(mtx)) != 0)
155
    STk_error_deadlock();
156 157 158

  while (MUTEX_LOCKED(mtx)) {
    if ((MUTEX_OWNER(mtx) != STk_false) &&
159
        (THREAD_STATE(MUTEX_OWNER(mtx)) == th_terminated)) {
160 161 162 163 164 165 166
      MUTEX_LOCKED(mtx) = FALSE;
      MUTEX_OWNER(mtx)  = STk_false;
      res = MUTEX_OWNER(mtx);
      break;
    }
    if (tm != STk_false) {
      int n = pthread_cond_timedwait(&MUTEX_MYCONDV(mtx), &MUTEX_MYMUTEX(mtx), &ts);
167

Erick Gallesio's avatar
.  
Erick Gallesio committed
168
      if (n == ETIMEDOUT) { res = STk_false; break; }
169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188
    }
    else
      pthread_cond_wait(&MUTEX_MYCONDV(mtx), &MUTEX_MYMUTEX(mtx));
  }
  if (res == STk_true) {
    /* We can lock the mutex */
    MUTEX_LOCKED(mtx) = TRUE;
    MUTEX_OWNER(mtx) = thread;
  }
  pthread_mutex_unlock(&MUTEX_MYMUTEX(mtx));
  pthread_cleanup_pop(0);

  /* Different cases for res:
   *  - The owning thread which is now terminated (a condition must be raised)
   *  - #f: we had a timeout
   *  - #t: otherwise
   */
  return res;
}

eg's avatar
eg committed
189 190 191 192 193
/*
<doc EXT mutex-unlock!
 * (mutex-unlock! mutex)
 * (mutex-unlock! mutex condition-variable)
 * (mutex-unlock! mutex condition-variable timeout)
194 195 196 197 198 199 200 201
 *
 * Unlocks the |mutex| by making it unlocked/not-abandoned. It is not an error
 * to unlock an unlocked mutex and a mutex that is owned by any thread.
 * If |condition-variable| is supplied, the current thread is blocked and
 * added to the |condition-variable| before unlocking |mutex|; the thread
 * can unblock at any time but no later than when an appropriate call to
 * |condition-variable-signal!| or |condition-variable-broadcast!| is
 * performed (see below), and no later than the timeout (if timeout is
eg's avatar
eg committed
202
 * supplied). If there are threads waiting to lock this mutex, the scheduler
203 204
 * selects a thread, the |mutex| becomes locked/owned or locked/not-owned,
 * and the thread is unblocked. |mutex-unlock!| returns |#f| when the
eg's avatar
eg committed
205 206 207
 * |timeout| is reached, otherwise it returns |#t|.
doc>
*/
208 209 210 211 212
DEFINE_PRIMITIVE("%mutex-unlock!", mutex_unlock, subr3, (SCM mtx, SCM cv, SCM tm))
{
  struct timespec ts;
  SCM res = STk_true;

213
  if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
eg's avatar
eg committed
214
  if ((cv != STk_false) && (!CONDVP(cv))) STk_error_bad_condv(cv);
215 216 217

  if (!BOOLEANP(tm)) {
    double tmd = STk_verify_timeout(tm);
218
    ts.tv_sec  = (time_t) tmd;
219
    ts.tv_nsec = (suseconds_t) ((tmd - ts.tv_sec) * 1000000000);
220
  }
221

222 223 224
  pthread_cleanup_push((void (*)(void*))mutex_finalizer, mtx);

  if (pthread_mutex_lock(&MUTEX_MYMUTEX(mtx)) != 0)
225
    STk_error_deadlock();
226 227 228 229

  /* Go in the unlocked/abandonned state */
  MUTEX_LOCKED(mtx) = FALSE;
  MUTEX_OWNER(mtx)  = STk_false;
230

231 232 233 234
  /* Signal to waiting threads */
  pthread_cond_signal(&MUTEX_MYCONDV(mtx));
  if (cv != STk_false) {
    if (tm != STk_false) {
Erick Gallesio's avatar
.  
Erick Gallesio committed
235
      int n = pthread_cond_timedwait(&CONDV_MYCONDV(cv), &MUTEX_MYMUTEX(mtx), &ts);
236 237

      if (n == ETIMEDOUT) res = STk_false;
238
    } else {
Erick Gallesio's avatar
.  
Erick Gallesio committed
239
      pthread_cond_wait(&CONDV_MYCONDV(cv), &MUTEX_MYMUTEX(mtx));
240 241 242 243 244 245 246 247
    }
  }
  pthread_mutex_unlock(&MUTEX_MYMUTEX(mtx));
  pthread_cleanup_pop(0);
  return res;
}


eg's avatar
eg committed
248 249
/* ====================================================================== *\
 *
250
 *                             C O N D   V A R S
251
 *
eg's avatar
eg committed
252 253
\* ====================================================================== */

254
#ifdef THREAD_FINALIZER_ISSUE
255
static void condv_finalizer(SCM cv)
eg's avatar
eg committed
256 257 258
{
  pthread_cond_destroy(&CONDV_MYCONDV(cv));
}
259
#endif
eg's avatar
eg committed
260

261
void STk_make_sys_condv(SCM z)
eg's avatar
eg committed
262 263 264
{
  pthread_cond_init(&CONDV_MYCONDV(z), NULL);

265
#ifdef THREAD_FINALIZER_ISSUE
266 267
  STk_register_finalizer(z, condv_finalizer);
#endif
eg's avatar
eg committed
268 269
}

eg's avatar
eg committed
270 271 272 273

/*
<doc EXT condition-variable-signal!
 * (condition-variable-signal! condition-variable)
274 275 276
 *
 * If there are threads blocked on the |condition-variable|, the scheduler
 * selects a thread and unblocks it. |Condition-variable-signal!|  returns
eg's avatar
eg committed
277 278 279
 * an unspecified value.
doc>
*/
eg's avatar
eg committed
280 281
DEFINE_PRIMITIVE("condition-variable-signal!", condv_signal, subr1, (SCM cv))
{
282
   if (! CONDVP(cv)) STk_error_bad_condv(cv);
eg's avatar
eg committed
283 284 285 286
   pthread_cond_signal(&CONDV_MYCONDV(cv));
   return STk_void;
}

eg's avatar
eg committed
287 288 289
/*
<doc EXT condition-variable-broadcast!
 * (condition-variable-broadcast! condition-variable)
290 291
 *
 * Unblocks all the threads blocked on the |condition-variable|.
eg's avatar
eg committed
292 293 294
 * |Condition-variable-broadcast!| returns an unspecified value.
doc>
*/
295
DEFINE_PRIMITIVE("condition-variable-broadcast!", condv_broadcast, subr1, (SCM cv))
eg's avatar
eg committed
296
{
297
   if (! CONDVP(cv)) STk_error_bad_condv(cv);
eg's avatar
eg committed
298 299 300
   pthread_cond_broadcast(&CONDV_MYCONDV(cv));
   return STk_void;
}