1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
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
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
#ifndef _WIN32THREAD_H
#define _WIN32THREAD_H
#include "win32.h"
typedef struct win32_cond { LONG waiters; HANDLE sem; } perl_cond;
typedef DWORD perl_key;
typedef HANDLE perl_os_thread;
#ifndef DONT_USE_CRITICAL_SECTION
/* Critical Sections used instead of mutexes: lightweight,
* but can't be communicated to child processes, and can't get
* HANDLE to it for use elsewhere.
*/
typedef CRITICAL_SECTION perl_mutex;
#define MUTEX_INIT(m) InitializeCriticalSection(m)
#define MUTEX_LOCK(m) EnterCriticalSection(m)
#define MUTEX_UNLOCK(m) LeaveCriticalSection(m)
#define MUTEX_DESTROY(m) DeleteCriticalSection(m)
#else
typedef HANDLE perl_mutex;
# define MUTEX_INIT(m) \
STMT_START { \
if ((*(m) = CreateMutex(NULL,FALSE,NULL)) == NULL) \
Perl_croak_nocontext("panic: MUTEX_INIT"); \
} STMT_END
# define MUTEX_LOCK(m) \
STMT_START { \
if (WaitForSingleObject(*(m),INFINITE) == WAIT_FAILED) \
Perl_croak_nocontext("panic: MUTEX_LOCK"); \
} STMT_END
# define MUTEX_UNLOCK(m) \
STMT_START { \
if (ReleaseMutex(*(m)) == 0) \
Perl_croak_nocontext("panic: MUTEX_UNLOCK"); \
} STMT_END
# define MUTEX_DESTROY(m) \
STMT_START { \
if (CloseHandle(*(m)) == 0) \
Perl_croak_nocontext("panic: MUTEX_DESTROY"); \
} STMT_END
#endif
/* These macros assume that the mutex associated with the condition
* will always be held before COND_{SIGNAL,BROADCAST,WAIT,DESTROY},
* so there's no separate mutex protecting access to (c)->waiters
*/
#define COND_INIT(c) \
STMT_START { \
(c)->waiters = 0; \
(c)->sem = Win_CreateSemaphore(NULL,0,LONG_MAX,NULL); \
if ((c)->sem == NULL) \
Perl_croak_nocontext("panic: COND_INIT (%ld)",GetLastError()); \
} STMT_END
#define COND_SIGNAL(c) \
STMT_START { \
if ((c)->waiters > 0 && \
ReleaseSemaphore((c)->sem,1,NULL) == 0) \
Perl_croak_nocontext("panic: COND_SIGNAL (%ld)",GetLastError()); \
} STMT_END
#define COND_BROADCAST(c) \
STMT_START { \
if ((c)->waiters > 0 && \
ReleaseSemaphore((c)->sem,(c)->waiters,NULL) == 0) \
Perl_croak_nocontext("panic: COND_BROADCAST (%ld)",GetLastError());\
} STMT_END
#define COND_WAIT(c, m) \
STMT_START { \
(c)->waiters++; \
MUTEX_UNLOCK(m); \
/* Note that there's no race here, since a \
* COND_BROADCAST() on another thread will have seen the\
* right number of waiters (i.e. including this one) */ \
if (WaitForSingleObject((c)->sem,INFINITE)==WAIT_FAILED)\
Perl_croak_nocontext("panic: COND_WAIT (%ld)",GetLastError()); \
/* XXX there may be an inconsequential race here */ \
MUTEX_LOCK(m); \
(c)->waiters--; \
} STMT_END
#define COND_DESTROY(c) \
STMT_START { \
(c)->waiters = 0; \
if (CloseHandle((c)->sem) == 0) \
Perl_croak_nocontext("panic: COND_DESTROY (%ld)",GetLastError()); \
} STMT_END
#define DETACH(t) \
STMT_START { \
if (CloseHandle((t)->self) == 0) { \
MUTEX_UNLOCK(&(t)->mutex); \
Perl_croak_nocontext("panic: DETACH"); \
} \
} STMT_END
#define THREAD_CREATE(t, f) Perl_thread_create(t, f)
#define THREAD_POST_CREATE(t) NOOP
/* XXX Docs mention that the RTL versions of thread creation routines
* should be used, but that advice only seems applicable when the RTL
* is not in a DLL. RTL DLLs seem to do all of the init/deinit required
* upon DLL_THREAD_ATTACH/DETACH. So we seem to be completely safe using
* straight Win32 API calls, rather than the much braindamaged RTL calls.
*
* _beginthread() in the RTLs call CloseHandle() just after the thread
* function returns, which means: 1) we have a race on our hands
* 2) it is impossible to implement join() semantics.
*
* IOW, do *NOT* turn on USE_RTL_THREAD_API! It is here
* for experimental purposes only. GSAR 98-01-02
*/
#ifdef USE_RTL_THREAD_API
# include <process.h>
# if defined (_MSC_VER)
# define THREAD_RET_TYPE unsigned __stdcall
# define THREAD_RET_CAST(p) ((unsigned)(p))
# else
/* CRTDLL.DLL doesn't allow a return value from thread function! */
# define THREAD_RET_TYPE void __cdecl
# define THREAD_RET_CAST(p) ((void)(thr->i.retv = (void *)(p)))
# endif
#else /* !USE_RTL_THREAD_API */
# define THREAD_RET_TYPE DWORD WINAPI
# define THREAD_RET_CAST(p) ((DWORD)(p))
#endif /* !USE_RTL_THREAD_API */
typedef THREAD_RET_TYPE thread_func_t(void *);
START_EXTERN_C
#if defined(PERLDLL) && defined(USE_DECLSPEC_THREAD)
extern __declspec(thread) void *PL_current_context;
#define PERL_SET_CONTEXT(t) (PL_current_context = t)
#define PERL_GET_CONTEXT PL_current_context
#else
#define PERL_GET_CONTEXT Perl_get_context()
#define PERL_SET_CONTEXT(t) Perl_set_context(t)
#endif
END_EXTERN_C
#define INIT_THREADS NOOP
#define ALLOC_THREAD_KEY \
STMT_START { \
if ((PL_thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) { \
PerlIO_printf(PerlIO_stderr(),"panic: TlsAlloc"); \
exit(1); \
} \
} STMT_END
#define FREE_THREAD_KEY \
STMT_START { \
TlsFree(PL_thr_key); \
} STMT_END
#define PTHREAD_ATFORK(prepare,parent,child) NOOP
#if defined(USE_RTL_THREAD_API) && !defined(_MSC_VER)
#define JOIN(t, avp) \
STMT_START { \
if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \
|| (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0) \
|| (CloseHandle((t)->self) == 0)) \
Perl_croak_nocontext("panic: JOIN"); \
*avp = (AV *)((t)->i.retv); \
} STMT_END
#else /* !USE_RTL_THREAD_API || _MSC_VER */
#define JOIN(t, avp) \
STMT_START { \
if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \
|| (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0) \
|| (CloseHandle((t)->self) == 0)) \
Perl_croak_nocontext("panic: JOIN"); \
} STMT_END
#endif /* !USE_RTL_THREAD_API || _MSC_VER */
#define YIELD Sleep(0)
#endif /* _WIN32THREAD_H */
|
