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 |