package / ocaml-base-compiler.4.10.0 / otherlibs / systhreads / st_win32.h
435 lines | 10940 chars
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 /* Win32 implementation of the "st" interface */
17
18 #undef _WIN32_WINNT
19 #define _WIN32_WINNT 0x0400
20 #include <windows.h>
21 #include <winerror.h>
22 #include <stdio.h>
23 #include <signal.h>
24
25 #include <caml/osdeps.h>
26
27 #define INLINE __inline
28
29 #if 1
30 #define TRACE(x)
31 #define TRACE1(x,y)
32 #else
33 #include <stdio.h>
34 #define TRACE(x) printf("%d: %s\n", GetCurrentThreadId(), x); fflush(stdout)
35 #define TRACE1(x,y) printf("%d: %s %p\n", GetCurrentThreadId(), x, (void *)y); \
36 fflush(stdout)
37 #endif
38
39 typedef DWORD st_retcode;
40
41 #define SIGPREEMPTION SIGTERM
42
43 /* Thread-local storage associating a Win32 event to every thread. */
44 static DWORD st_thread_sem_key;
45
46 /* OS-specific initialization */
47
48 static DWORD st_initialize(void)
49 {
50 st_thread_sem_key = TlsAlloc();
51 if (st_thread_sem_key == TLS_OUT_OF_INDEXES)
52 return GetLastError();
53 else
54 return 0;
55 }
56
57 /* Thread creation. Created in detached mode if [res] is NULL. */
58
59 typedef HANDLE st_thread_id;
60
61 static DWORD st_thread_create(st_thread_id * res,
62 LPTHREAD_START_ROUTINE fn, void * arg)
63 {
64 HANDLE h = CreateThread(NULL, 0, fn, arg, 0, NULL);
65 TRACE1("st_thread_create", h);
66 if (h == NULL) return GetLastError();
67 if (res == NULL)
68 CloseHandle(h);
69 else
70 *res = h;
71 return 0;
72 }
73
74 #define ST_THREAD_FUNCTION DWORD WINAPI
75
76 /* Cleanup at thread exit */
77
78 static void st_thread_cleanup(void)
79 {
80 HANDLE ev = (HANDLE) TlsGetValue(st_thread_sem_key);
81 if (ev != NULL) CloseHandle(ev);
82 }
83
84 /* Thread termination */
85
86 CAMLnoreturn_start
87 static void st_thread_exit(void)
88 CAMLnoreturn_end;
89
90 static void st_thread_exit(void)
91 {
92 TRACE("st_thread_exit");
93 ExitThread(0);
94 }
95
96 static void st_thread_join(st_thread_id thr)
97 {
98 TRACE1("st_thread_join", h);
99 WaitForSingleObject(thr, INFINITE);
100 }
101
102 /* Thread-specific state */
103
104 typedef DWORD st_tlskey;
105
106 static DWORD st_tls_newkey(st_tlskey * res)
107 {
108 *res = TlsAlloc();
109 if (*res == TLS_OUT_OF_INDEXES)
110 return GetLastError();
111 else
112 return 0;
113 }
114
115 static INLINE void * st_tls_get(st_tlskey k)
116 {
117 return TlsGetValue(k);
118 }
119
120 static INLINE void st_tls_set(st_tlskey k, void * v)
121 {
122 TlsSetValue(k, v);
123 }
124
125 /* The master lock. */
126
127 typedef CRITICAL_SECTION st_masterlock;
128
129 static void st_masterlock_init(st_masterlock * m)
130 {
131 TRACE("st_masterlock_init");
132 InitializeCriticalSection(m);
133 EnterCriticalSection(m);
134 }
135
136 static INLINE void st_masterlock_acquire(st_masterlock * m)
137 {
138 TRACE("st_masterlock_acquire");
139 EnterCriticalSection(m);
140 TRACE("st_masterlock_acquire (done)");
141 }
142
143 static INLINE void st_masterlock_release(st_masterlock * m)
144 {
145 LeaveCriticalSection(m);
146 TRACE("st_masterlock_released");
147 }
148
149 static INLINE int st_masterlock_waiters(st_masterlock * m)
150 {
151 return 1; /* info not maintained */
152 }
153
154 /* Scheduling hints */
155
156 static INLINE void st_thread_yield(st_masterlock * m)
157 {
158 LeaveCriticalSection(m);
159 Sleep(0);
160 EnterCriticalSection(m);
161 }
162
163 /* Mutexes */
164
165 typedef CRITICAL_SECTION * st_mutex;
166
167 static DWORD st_mutex_create(st_mutex * res)
168 {
169 st_mutex m = caml_stat_alloc_noexc(sizeof(CRITICAL_SECTION));
170 if (m == NULL) return ERROR_NOT_ENOUGH_MEMORY;
171 InitializeCriticalSection(m);
172 *res = m;
173 return 0;
174 }
175
176 static DWORD st_mutex_destroy(st_mutex m)
177 {
178 DeleteCriticalSection(m);
179 caml_stat_free(m);
180 return 0;
181 }
182
183 static INLINE DWORD st_mutex_lock(st_mutex m)
184 {
185 TRACE1("st_mutex_lock", m);
186 EnterCriticalSection(m);
187 TRACE1("st_mutex_lock (done)", m);
188 return 0;
189 }
190
191 /* Error codes with the 29th bit set are reserved for the application */
192
193 #define PREVIOUSLY_UNLOCKED 0
194 #define ALREADY_LOCKED (1<<29)
195
196 static INLINE DWORD st_mutex_trylock(st_mutex m)
197 {
198 TRACE1("st_mutex_trylock", m);
199 if (TryEnterCriticalSection(m)) {
200 TRACE1("st_mutex_trylock (success)", m);
201 return PREVIOUSLY_UNLOCKED;
202 } else {
203 TRACE1("st_mutex_trylock (failure)", m);
204 return ALREADY_LOCKED;
205 }
206 }
207
208 static INLINE DWORD st_mutex_unlock(st_mutex m)
209 {
210 TRACE1("st_mutex_unlock", m);
211 LeaveCriticalSection(m);
212 return 0;
213 }
214
215 /* Condition variables */
216
217 /* A condition variable is just a list of threads currently
218 waiting on this c.v. Each thread is represented by its
219 associated event. */
220
221 struct st_wait_list {
222 HANDLE event; /* event of the first waiting thread */
223 struct st_wait_list * next;
224 };
225
226 typedef struct st_condvar_struct {
227 CRITICAL_SECTION lock; /* protect the data structure */
228 struct st_wait_list * waiters; /* list of threads waiting */
229 } * st_condvar;
230
231 static DWORD st_condvar_create(st_condvar * res)
232 {
233 st_condvar c = caml_stat_alloc_noexc(sizeof(struct st_condvar_struct));
234 if (c == NULL) return ERROR_NOT_ENOUGH_MEMORY;
235 InitializeCriticalSection(&c->lock);
236 c->waiters = NULL;
237 *res = c;
238 return 0;
239 }
240
241 static DWORD st_condvar_destroy(st_condvar c)
242 {
243 TRACE1("st_condvar_destroy", c);
244 DeleteCriticalSection(&c->lock);
245 caml_stat_free(c);
246 return 0;
247 }
248
249 static DWORD st_condvar_signal(st_condvar c)
250 {
251 DWORD rc = 0;
252 struct st_wait_list * curr, * next;
253
254 TRACE1("st_condvar_signal", c);
255 EnterCriticalSection(&c->lock);
256 curr = c->waiters;
257 if (curr != NULL) {
258 next = curr->next;
259 /* Wake up the first waiting thread */
260 TRACE1("st_condvar_signal: waking up", curr->event);
261 if (! SetEvent(curr->event)) rc = GetLastError();
262 /* Remove it from the waiting list */
263 c->waiters = next;
264 }
265 LeaveCriticalSection(&c->lock);
266 return rc;
267 }
268
269 static DWORD st_condvar_broadcast(st_condvar c)
270 {
271 DWORD rc = 0;
272 struct st_wait_list * curr, * next;
273
274 TRACE1("st_condvar_broadcast", c);
275 EnterCriticalSection(&c->lock);
276 /* Wake up all waiting threads */
277 curr = c->waiters;
278 while (curr != NULL) {
279 next = curr->next;
280 TRACE1("st_condvar_signal: waking up", curr->event);
281 if (! SetEvent(curr->event)) rc = GetLastError();
282 curr = next;
283 }
284 /* Remove them all from the waiting list */
285 c->waiters = NULL;
286 LeaveCriticalSection(&c->lock);
287 return rc;
288 }
289
290 static DWORD st_condvar_wait(st_condvar c, st_mutex m)
291 {
292 HANDLE ev;
293 struct st_wait_list wait;
294
295 TRACE1("st_condvar_wait", c);
296 /* Recover (or create) the event associated with the calling thread */
297 ev = (HANDLE) TlsGetValue(st_thread_sem_key);
298 if (ev == 0) {
299 ev = CreateEvent(NULL,
300 FALSE /*auto reset*/,
301 FALSE /*initially unset*/,
302 NULL);
303 if (ev == NULL) return GetLastError();
304 TlsSetValue(st_thread_sem_key, (void *) ev);
305 }
306 EnterCriticalSection(&c->lock);
307 /* Insert the current thread in the waiting list (atomically) */
308 wait.event = ev;
309 wait.next = c->waiters;
310 c->waiters = &wait;
311 LeaveCriticalSection(&c->lock);
312 /* Release the mutex m */
313 LeaveCriticalSection(m);
314 /* Wait for our event to be signaled. There is no risk of lost
315 wakeup, since we inserted ourselves on the waiting list of c
316 before releasing m */
317 TRACE1("st_condvar_wait: blocking on event", ev);
318 if (WaitForSingleObject(ev, INFINITE) == WAIT_FAILED)
319 return GetLastError();
320 /* Reacquire the mutex m */
321 TRACE1("st_condvar_wait: restarted, acquiring mutex", m);
322 EnterCriticalSection(m);
323 TRACE1("st_condvar_wait: acquired mutex", m);
324 return 0;
325 }
326
327 /* Triggered events */
328
329 typedef HANDLE st_event;
330
331 static DWORD st_event_create(st_event * res)
332 {
333 st_event m =
334 CreateEvent(NULL, TRUE/*manual reset*/, FALSE/*initially unset*/, NULL);
335 TRACE1("st_event_create", m);
336 if (m == NULL) return GetLastError();
337 *res = m;
338 return 0;
339 }
340
341 static DWORD st_event_destroy(st_event e)
342 {
343 TRACE1("st_event_destroy", e);
344 if (CloseHandle(e))
345 return 0;
346 else
347 return GetLastError();
348 }
349
350 static DWORD st_event_trigger(st_event e)
351 {
352 TRACE1("st_event_trigger", e);
353 if (SetEvent(e))
354 return 0;
355 else
356 return GetLastError();
357 }
358
359 static DWORD st_event_wait(st_event e)
360 {
361 TRACE1("st_event_wait", e);
362 if (WaitForSingleObject(e, INFINITE) == WAIT_FAILED)
363 return GetLastError();
364 else
365 return 0;
366 }
367
368 /* Reporting errors */
369
370 static void st_check_error(DWORD retcode, char * msg)
371 {
372 wchar_t err[1024];
373 int errlen, msglen, ret;
374 value str;
375
376 if (retcode == 0) return;
377 if (retcode == ERROR_NOT_ENOUGH_MEMORY) caml_raise_out_of_memory();
378 ret = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS,
379 NULL,
380 retcode,
381 0,
382 err,
383 sizeof(err)/sizeof(wchar_t),
384 NULL);
385 if (! ret) {
386 ret =
387 swprintf(err, sizeof(err)/sizeof(wchar_t), L"error code %lx", retcode);
388 }
389 msglen = strlen(msg);
390 errlen = win_wide_char_to_multi_byte(err, ret, NULL, 0);
391 str = caml_alloc_string(msglen + 2 + errlen);
392 memmove (&Byte(str, 0), msg, msglen);
393 memmove (&Byte(str, msglen), ": ", 2);
394 win_wide_char_to_multi_byte(err, ret, &Byte(str, msglen + 2), errlen);
395 caml_raise_sys_error(str);
396 }
397
398 /* Variable used to stop the "tick" thread */
399 static volatile int caml_tick_thread_stop = 0;
400
401 /* The tick thread: posts a SIGPREEMPTION signal periodically */
402
403 static DWORD WINAPI caml_thread_tick(void * arg)
404 {
405 while(! caml_tick_thread_stop) {
406 Sleep(Thread_timeout);
407 /* The preemption signal should never cause a callback, so don't
408 go through caml_handle_signal(), just record signal delivery via
409 caml_record_signal(). */
410 caml_record_signal(SIGPREEMPTION);
411 }
412 return 0;
413 }
414
415 /* "At fork" processing -- none under Win32 */
416
417 static DWORD st_atfork(void (*fn)(void))
418 {
419 return 0;
420 }
421
422 /* Signal handling -- none under Win32 */
423
424 value caml_thread_sigmask(value cmd, value sigs) /* ML */
425 {
426 caml_invalid_argument("Thread.sigmask not implemented");
427 return Val_int(0); /* not reached */
428 }
429
430 value caml_wait_signal(value sigs) /* ML */
431 {
432 caml_invalid_argument("Thread.wait_signal not implemented");
433 return Val_int(0); /* not reached */
434 }
435