1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */
6 /* */
7 /* Copyright 2009 Institut National de Recherche en Informatique et */
8 /* en Automatique. */
9 /* */
10 /* All rights reserved. This file is distributed under the terms of */
11 /* the GNU Lesser General Public License version 2.1, with the */
12 /* special exception on linking described in the file LICENSE. */
13 /* */
14 /**************************************************************************/
15
16 /* POSIX thread implementation of the "st" interface */
17
18 #include <assert.h>
19 #include <errno.h>
20 #include <string.h>
21 #include <stdio.h>
22 #include <stdlib.h>
23 #include <pthread.h>
24 #ifdef __sun
25 #define _POSIX_PTHREAD_SEMANTICS
26 #endif
27 #include <signal.h>
28 #include <time.h>
29 #include <sys/time.h>
30 #ifdef __linux__
31 #include <unistd.h>
32 #endif
33
34 #ifdef __GNUC__
35 #define INLINE inline
36 #else
37 #define INLINE
38 #endif
39
40 typedef int st_retcode;
41
42 #define SIGPREEMPTION SIGVTALRM
43
44 /* OS-specific initialization */
45
46 static int st_initialize(void)
47 {
48 caml_sigmask_hook = pthread_sigmask;
49 return 0;
50 }
51
52 /* Thread creation. Created in detached mode if [res] is NULL. */
53
54 typedef pthread_t st_thread_id;
55
56 static int st_thread_create(st_thread_id * res,
57 void * (*fn)(void *), void * arg)
58 {
59 pthread_t thr;
60 pthread_attr_t attr;
61 int rc;
62
63 pthread_attr_init(&attr);
64 if (res == NULL) pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
65 rc = pthread_create(&thr, &attr, fn, arg);
66 if (res != NULL) *res = thr;
67 return rc;
68 }
69
70 #define ST_THREAD_FUNCTION void *
71
72 /* Cleanup at thread exit */
73
74 static INLINE void st_thread_cleanup(void)
75 {
76 return;
77 }
78
79 /* Thread termination */
80
81 CAMLnoreturn_start
82 static void st_thread_exit(void)
83 CAMLnoreturn_end;
84
85 static void st_thread_exit(void)
86 {
87 pthread_exit(NULL);
88 }
89
90 static void st_thread_join(st_thread_id thr)
91 {
92 pthread_join(thr, NULL);
93 /* best effort: ignore errors */
94 }
95
96 /* Thread-specific state */
97
98 typedef pthread_key_t st_tlskey;
99
100 static int st_tls_newkey(st_tlskey * res)
101 {
102 return pthread_key_create(res, NULL);
103 }
104
105 static INLINE void * st_tls_get(st_tlskey k)
106 {
107 return pthread_getspecific(k);
108 }
109
110 static INLINE void st_tls_set(st_tlskey k, void * v)
111 {
112 pthread_setspecific(k, v);
113 }
114
115 /* The master lock. This is a mutex that is held most of the time,
116 so we implement it in a slightly convoluted way to avoid
117 all risks of busy-waiting. Also, we count the number of waiting
118 threads. */
119
120 typedef struct {
121 pthread_mutex_t lock; /* to protect contents */
122 int busy; /* 0 = free, 1 = taken */
123 volatile int waiters; /* number of threads waiting on master lock */
124 pthread_cond_t is_free; /* signaled when free */
125 } st_masterlock;
126
127 static void st_masterlock_init(st_masterlock * m)
128 {
129 pthread_mutex_init(&m->lock, NULL);
130 pthread_cond_init(&m->is_free, NULL);
131 m->busy = 1;
132 m->waiters = 0;
133 }
134
135 static void st_masterlock_acquire(st_masterlock * m)
136 {
137 pthread_mutex_lock(&m->lock);
138 while (m->busy) {
139 m->waiters ++;
140 pthread_cond_wait(&m->is_free, &m->lock);
141 m->waiters --;
142 }
143 m->busy = 1;
144 pthread_mutex_unlock(&m->lock);
145 }
146
147 static void st_masterlock_release(st_masterlock * m)
148 {
149 pthread_mutex_lock(&m->lock);
150 m->busy = 0;
151 pthread_mutex_unlock(&m->lock);
152 pthread_cond_signal(&m->is_free);
153 }
154
155 CAMLno_tsan /* This can be called for reading [waiters] without locking. */
156 static INLINE int st_masterlock_waiters(st_masterlock * m)
157 {
158 return m->waiters;
159 }
160
161 /* Scheduling hints */
162
163 /* This is mostly equivalent to release(); acquire(), but better. In particular,
164 release(); acquire(); leaves both us and the waiter we signal() racing to
165 acquire the lock. Calling yield or sleep helps there but does not solve the
166 problem. Sleeping ourselves is much more reliable--and since we're handing
167 off the lock to a waiter we know exists, it's safe, as they'll certainly
168 re-wake us later.
169 */
170 static INLINE void st_thread_yield(st_masterlock * m)
171 {
172 pthread_mutex_lock(&m->lock);
173 /* We must hold the lock to call this. */
174 assert(m->busy);
175
176 /* We already checked this without the lock, but we might have raced--if
177 there's no waiter, there's nothing to do and no one to wake us if we did
178 wait, so just keep going. */
179 if (m->waiters == 0) {
180 pthread_mutex_unlock(&m->lock);
181 return;
182 }
183
184 m->busy = 0;
185 pthread_cond_signal(&m->is_free);
186 m->waiters++;
187 do {
188 /* Note: the POSIX spec prevents the above signal from pairing with this
189 wait, which is good: we'll reliably continue waiting until the next
190 yield() or enter_blocking_section() call (or we see a spurious condvar
191 wakeup, which are rare at best.) */
192 pthread_cond_wait(&m->is_free, &m->lock);
193 } while (m->busy);
194 m->busy = 1;
195 m->waiters--;
196 pthread_mutex_unlock(&m->lock);
197 }
198
199 /* Mutexes */
200
201 typedef pthread_mutex_t * st_mutex;
202
203 static int st_mutex_create(st_mutex * res)
204 {
205 int rc;
206 st_mutex m = caml_stat_alloc_noexc(sizeof(pthread_mutex_t));
207 if (m == NULL) return ENOMEM;
208 rc = pthread_mutex_init(m, NULL);
209 if (rc != 0) { caml_stat_free(m); return rc; }
210 *res = m;
211 return 0;
212 }
213
214 static int st_mutex_destroy(st_mutex m)
215 {
216 int rc;
217 rc = pthread_mutex_destroy(m);
218 caml_stat_free(m);
219 return rc;
220 }
221
222 static INLINE int st_mutex_lock(st_mutex m)
223 {
224 return pthread_mutex_lock(m);
225 }
226
227 #define PREVIOUSLY_UNLOCKED 0
228 #define ALREADY_LOCKED EBUSY
229
230 static INLINE int st_mutex_trylock(st_mutex m)
231 {
232 return pthread_mutex_trylock(m);
233 }
234
235 static INLINE int st_mutex_unlock(st_mutex m)
236 {
237 return pthread_mutex_unlock(m);
238 }
239
240 /* Condition variables */
241
242 typedef pthread_cond_t * st_condvar;
243
244 static int st_condvar_create(st_condvar * res)
245 {
246 int rc;
247 st_condvar c = caml_stat_alloc_noexc(sizeof(pthread_cond_t));
248 if (c == NULL) return ENOMEM;
249 rc = pthread_cond_init(c, NULL);
250 if (rc != 0) { caml_stat_free(c); return rc; }
251 *res = c;
252 return 0;
253 }
254
255 static int st_condvar_destroy(st_condvar c)
256 {
257 int rc;
258 rc = pthread_cond_destroy(c);
259 caml_stat_free(c);
260 return rc;
261 }
262
263 static INLINE int st_condvar_signal(st_condvar c)
264 {
265 return pthread_cond_signal(c);
266 }
267
268 static INLINE int st_condvar_broadcast(st_condvar c)
269 {
270 return pthread_cond_broadcast(c);
271 }
272
273 static INLINE int st_condvar_wait(st_condvar c, st_mutex m)
274 {
275 return pthread_cond_wait(c, m);
276 }
277
278 /* Triggered events */
279
280 typedef struct st_event_struct {
281 pthread_mutex_t lock; /* to protect contents */
282 int status; /* 0 = not triggered, 1 = triggered */
283 pthread_cond_t triggered; /* signaled when triggered */
284 } * st_event;
285
286 static int st_event_create(st_event * res)
287 {
288 int rc;
289 st_event e = caml_stat_alloc_noexc(sizeof(struct st_event_struct));
290 if (e == NULL) return ENOMEM;
291 rc = pthread_mutex_init(&e->lock, NULL);
292 if (rc != 0) { caml_stat_free(e); return rc; }
293 rc = pthread_cond_init(&e->triggered, NULL);
294 if (rc != 0)
295 { pthread_mutex_destroy(&e->lock); caml_stat_free(e); return rc; }
296 e->status = 0;
297 *res = e;
298 return 0;
299 }
300
301 static int st_event_destroy(st_event e)
302 {
303 int rc1, rc2;
304 rc1 = pthread_mutex_destroy(&e->lock);
305 rc2 = pthread_cond_destroy(&e->triggered);
306 caml_stat_free(e);
307 return rc1 != 0 ? rc1 : rc2;
308 }
309
310 static int st_event_trigger(st_event e)
311 {
312 int rc;
313 rc = pthread_mutex_lock(&e->lock);
314 if (rc != 0) return rc;
315 e->status = 1;
316 rc = pthread_mutex_unlock(&e->lock);
317 if (rc != 0) return rc;
318 rc = pthread_cond_broadcast(&e->triggered);
319 return rc;
320 }
321
322 static int st_event_wait(st_event e)
323 {
324 int rc;
325 rc = pthread_mutex_lock(&e->lock);
326 if (rc != 0) return rc;
327 while(e->status == 0) {
328 rc = pthread_cond_wait(&e->triggered, &e->lock);
329 if (rc != 0) return rc;
330 }
331 rc = pthread_mutex_unlock(&e->lock);
332 return rc;
333 }
334
335 /* Reporting errors */
336
337 static void st_check_error(int retcode, char * msg)
338 {
339 char * err;
340 int errlen, msglen;
341 value str;
342
343 if (retcode == 0) return;
344 if (retcode == ENOMEM) caml_raise_out_of_memory();
345 err = strerror(retcode);
346 msglen = strlen(msg);
347 errlen = strlen(err);
348 str = caml_alloc_string(msglen + 2 + errlen);
349 memmove (&Byte(str, 0), msg, msglen);
350 memmove (&Byte(str, msglen), ": ", 2);
351 memmove (&Byte(str, msglen + 2), err, errlen);
352 caml_raise_sys_error(str);
353 }
354
355 /* Variable used to stop the "tick" thread */
356 static volatile int caml_tick_thread_stop = 0;
357
358 /* The tick thread: posts a SIGPREEMPTION signal periodically */
359
360 static void * caml_thread_tick(void * arg)
361 {
362 struct timeval timeout;
363 sigset_t mask;
364
365 /* Block all signals so that we don't try to execute an OCaml signal handler*/
366 sigfillset(&mask);
367 pthread_sigmask(SIG_BLOCK, &mask, NULL);
368 while(! caml_tick_thread_stop) {
369 /* select() seems to be the most efficient way to suspend the
370 thread for sub-second intervals */
371 timeout.tv_sec = 0;
372 timeout.tv_usec = Thread_timeout * 1000;
373 select(0, NULL, NULL, NULL, &timeout);
374 /* The preemption signal should never cause a callback, so don't
375 go through caml_handle_signal(), just record signal delivery via
376 caml_record_signal(). */
377 caml_record_signal(SIGPREEMPTION);
378 }
379 return NULL;
380 }
381
382 /* "At fork" processing */
383
384 #if defined(__ANDROID__)
385 /* Android's libc does not include declaration of pthread_atfork;
386 however, it implements it since API level 10 (Gingerbread).
387 The reason for the omission is that Android (GUI) applications
388 are not supposed to fork at all, however this workaround is still
389 included in case OCaml is used for an Android CLI utility. */
390 int pthread_atfork(void (*prepare)(void), void (*parent)(void),
391 void (*child)(void));
392 #endif
393
394 static int st_atfork(void (*fn)(void))
395 {
396 return pthread_atfork(NULL, NULL, fn);
397 }
398
399 /* Signal handling */
400
401 static void st_decode_sigset(value vset, sigset_t * set)
402 {
403 sigemptyset(set);
404 while (vset != Val_int(0)) {
405 int sig = caml_convert_signal_number(Int_val(Field(vset, 0)));
406 sigaddset(set, sig);
407 vset = Field(vset, 1);
408 }
409 }
410
411 #ifndef NSIG
412 #define NSIG 64
413 #endif
414
415 static value st_encode_sigset(sigset_t * set)
416 {
417 value res = Val_int(0);
418 int i;
419
420 Begin_root(res)
421 for (i = 1; i < NSIG; i++)
422 if (sigismember(set, i) > 0) {
423 value newcons = caml_alloc_small(2, 0);
424 Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i));
425 Field(newcons, 1) = res;
426 res = newcons;
427 }
428 End_roots();
429 return res;
430 }
431
432 static int sigmask_cmd[3] = { SIG_SETMASK, SIG_BLOCK, SIG_UNBLOCK };
433
434 value caml_thread_sigmask(value cmd, value sigs) /* ML */
435 {
436 int how;
437 sigset_t set, oldset;
438 int retcode;
439
440 how = sigmask_cmd[Int_val(cmd)];
441 st_decode_sigset(sigs, &set);
442 caml_enter_blocking_section();
443 retcode = pthread_sigmask(how, &set, &oldset);
444 caml_leave_blocking_section();
445 st_check_error(retcode, "Thread.sigmask");
446 return st_encode_sigset(&oldset);
447 }
448
449 value caml_wait_signal(value sigs) /* ML */
450 {
451 #ifdef HAS_SIGWAIT
452 sigset_t set;
453 int retcode, signo;
454
455 st_decode_sigset(sigs, &set);
456 caml_enter_blocking_section();
457 retcode = sigwait(&set, &signo);
458 caml_leave_blocking_section();
459 st_check_error(retcode, "Thread.wait_signal");
460 return Val_int(caml_rev_convert_signal_number(signo));
461 #else
462 caml_invalid_argument("Thread.wait_signal not implemented");
463 return Val_int(0); /* not reached */
464 #endif
465 }
466