mutex-pthreads.c 8.96 KB
Newer Older
eg's avatar
eg committed
1
/*
2
 * mutex-pthreads.c	-- Pthread Mutexes in Scheme
eg's avatar
eg committed
3
 * 
4
 * Copyright  2006-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
eg's avatar
eg committed
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
 * 
 * 
 * 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.
 * 
 * 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.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 
 * USA.
 * 
 *           Author: Erick Gallesio [eg@essi.fr]
 *    Creation date:  2-Feb-2006 21:58 (eg)
24
 * Last file update: 19-Nov-2007 11:10 (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 37 38 39


/* ====================================================================== *\
 *
 * 			       M U T E X E S
 * 
\* ====================================================================== */

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
void STk_make_sys_mutex(SCM z)
eg's avatar
eg committed
47 48 49 50
{
  pthread_mutex_init(&MUTEX_MYMUTEX(z), NULL);
  pthread_cond_init(&MUTEX_MYCONDV(z), NULL);

eg's avatar
eg committed
51
  // STk_register_finalizer(z, mutex_finalizer);
eg's avatar
eg committed
52 53
}

eg's avatar
eg committed
54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
/*
<doc EXT mutex-state
 * (mutex-state mutex)
 * 
 * Returns information about the state of the |mutex|. The possible results 
 * are:
 * ,(itemize
 *  (item [,(bold "thread T"): the mutex is in the locked/owned state and
 *     thread T is the owner of the mutex])
 *  (item [,(bold "symbol not-owned"): the mutex is in the locked/not-owned 
 *     state])
 *  (item [,(bold "symbol abandoned"): the mutex is in the unlocked/abandoned 
 *      state])
 *  (item [,(bold "symbol not-abandoned"): the mutex is in the 
 *      unlocked/not-abandoned state]))
 * @lisp
 * (mutex-state (make-mutex))  =>  not-abandoned
 * 
 * (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
81 82 83 84
DEFINE_PRIMITIVE("mutex-state", mutex_state, subr1, (SCM mtx))
{
  SCM res;

85
  if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
eg's avatar
eg committed
86 87 88
  
  pthread_mutex_lock(&MUTEX_MYMUTEX(mtx));

eg's avatar
eg committed
89 90 91 92 93 94 95
  if (MUTEX_LOCKED(mtx) && 
      (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
96
  if (MUTEX_LOCKED(mtx))
97
    res = (MUTEX_OWNER(mtx) == STk_false) ? STk_sym_not_owned : MUTEX_OWNER(mtx);
eg's avatar
eg committed
98
  else 
99
    res = (MUTEX_OWNER(mtx) == STk_false) ? STk_sym_not_abandoned: STk_sym_abandoned;
eg's avatar
eg committed
100 101 102 103 104 105 106
  
  pthread_mutex_unlock(&MUTEX_MYMUTEX(mtx));

  return res;
}


eg's avatar
eg committed
107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136
/*
<doc EXT mutex-lock!
 * (mutex-lock! mutex)
 * (mutex-lock! mutex timeout)
 * (mutex-lock! mutex timeout thread)
 * 
 * If the |mutex| is currently locked, the current thread waits until the
 * |mutex| is unlocked, or until the timeout is reached if |timeout| is supplied. 
 * If the |timeout| is reached, |mutex-lock!| returns |#f|. 
 * Otherwise, the state of the mutex is changed as follows:
 * ,(itemize 
 *  (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),
 *         ,(itemize 
 *           (item [if T is terminated the mutex becomes unlocked/abandoned,])
 *           (item [otherwise mutex becomes locked/owned with T as the owner.]))]))
 * 
 * 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|. 
 * @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>
*/
137 138 139 140 141 142
DEFINE_PRIMITIVE("%mutex-lock!", mutex_lock, subr3, (SCM mtx, SCM tm, SCM thread))
{
  struct timespec ts;
  double tmd;
  SCM res = STk_true;

143
  if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
144 145 146 147 148 149
  if (REALP(tm)) {
    tmd = REAL_VAL(tm);
    ts.tv_sec  = (time_t) tmd;
    ts.tv_nsec = (suseconds_t) ((tmd - ts.tv_sec) * 1000000);
  }
  else if (!BOOLEANP(tm))
150
    STk_error_bad_timeout(tm);
151 152 153 154

  pthread_cleanup_push((void (*)(void*))mutex_finalizer, mtx);
  
  if (pthread_mutex_lock(&MUTEX_MYMUTEX(mtx)) != 0)
155
    STk_error_deadlock();
156 157 158 159 160 161 162 163 164 165 166 167

  while (MUTEX_LOCKED(mtx)) {
    if ((MUTEX_OWNER(mtx) != STk_false) &&
 	(THREAD_STATE(MUTEX_OWNER(mtx)) == th_terminated)) {
      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);
      
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 194 195 196 197 198 199 200 201 202 203 204 205 206 207
/*
<doc EXT mutex-unlock!
 * (mutex-unlock! mutex)
 * (mutex-unlock! mutex condition-variable)
 * (mutex-unlock! mutex condition-variable timeout)
 * 
 * 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 
 * supplied). If there are threads waiting to lock this mutex, the scheduler
 * selects a thread, the |mutex| becomes locked/owned or locked/not-owned, 
 * and the thread is unblocked. |mutex-unlock!| returns |#f| when the 
 * |timeout| is reached, otherwise it returns |#t|.
doc>
*/
208 209 210 211 212 213
DEFINE_PRIMITIVE("%mutex-unlock!", mutex_unlock, subr3, (SCM mtx, SCM cv, SCM tm))
{
  struct timespec ts;
  double tmd;
  SCM res = STk_true;

214
  if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
eg's avatar
eg committed
215
  if ((cv != STk_false) && (!CONDVP(cv))) STk_error_bad_condv(cv);
216 217 218
  if (REALP(tm)) {
    tmd = REAL_VAL(tm);
    ts.tv_sec  = (time_t) tmd;
219
    ts.tv_nsec = (suseconds_t) ((tmd - ts.tv_sec) * 1000000000);
220 221
  }
  else if (!BOOLEANP(tm))
222
    STk_error_bad_timeout(tm);
223 224 225 226
  
  pthread_cleanup_push((void (*)(void*))mutex_finalizer, mtx);

  if (pthread_mutex_lock(&MUTEX_MYMUTEX(mtx)) != 0)
227
    STk_error_deadlock();
228 229 230 231 232 233 234 235 236

  /* Go in the unlocked/abandonned state */
  MUTEX_LOCKED(mtx) = FALSE;
  MUTEX_OWNER(mtx)  = STk_false;
  
  /* 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
237
      int n = pthread_cond_timedwait(&CONDV_MYCONDV(cv), &MUTEX_MYMUTEX(mtx), &ts);
238 239 240
      
      if (n == ETIMEDOUT) res = STk_false; 
    } else {
Erick Gallesio's avatar
.  
Erick Gallesio committed
241
      pthread_cond_wait(&CONDV_MYCONDV(cv), &MUTEX_MYMUTEX(mtx));
242 243 244 245 246 247 248 249
    }
  }
  pthread_mutex_unlock(&MUTEX_MYMUTEX(mtx));
  pthread_cleanup_pop(0);
  return res;
}


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

256
static void condv_finalizer(SCM cv)
eg's avatar
eg committed
257 258 259 260
{
  pthread_cond_destroy(&CONDV_MYCONDV(cv));
}

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

eg's avatar
eg committed
265
  //   STk_register_finalizer(z, condv_finalizer);
eg's avatar
eg committed
266 267
}

eg's avatar
eg committed
268 269 270 271 272 273 274 275 276 277

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

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