ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/OpenCL/schmorp.h
Revision: 1.2
Committed: Tue Oct 22 17:25:38 2013 UTC (10 years, 8 months ago) by root
Content type: text/plain
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +3 -3 lines
Log Message:
*** empty log message ***

File Contents

# Content
1 #ifndef SCHMORP_PERL_H_
2 #define SCHMORP_PERL_H_
3
4 /* WARNING
5 * This header file is a shared resource between many modules.
6 * perl header files MUST already be included.
7 */
8
9 #include <signal.h>
10 #include <errno.h>
11
12 #if defined(WIN32 ) || defined(_MINIX)
13 # define SCHMORP_H_PREFER_SELECT 1
14 #endif
15
16 #if !SCHMORP_H_PREFER_SELECT
17 # include <poll.h>
18 #endif
19
20 /* useful stuff, used by schmorp mostly */
21
22 #include "patchlevel.h"
23
24 #define PERL_VERSION_ATLEAST(a,b,c) \
25 (PERL_REVISION > (a) \
26 || (PERL_REVISION == (a) \
27 && (PERL_VERSION > (b) \
28 || (PERL_VERSION == (b) && PERL_SUBVERSION >= (c)))))
29
30 #ifndef PERL_MAGIC_ext
31 # define PERL_MAGIC_ext '~'
32 #endif
33
34 #if !PERL_VERSION_ATLEAST (5,6,0)
35 # ifndef PL_ppaddr
36 # define PL_ppaddr ppaddr
37 # endif
38 # ifndef call_sv
39 # define call_sv perl_call_sv
40 # endif
41 # ifndef get_sv
42 # define get_sv perl_get_sv
43 # endif
44 # ifndef get_cv
45 # define get_cv perl_get_cv
46 # endif
47 # ifndef IS_PADGV
48 # define IS_PADGV(v) 0
49 # endif
50 # ifndef IS_PADCONST
51 # define IS_PADCONST(v) 0
52 # endif
53 #endif
54
55 /* use NV for 32 bit perls as it allows larger offsets */
56 #if IVSIZE >= 8
57 typedef IV VAL64;
58 # define SvVAL64(sv) SvIV (sv)
59 # define newSVval64(i64) newSViv (i64)
60 #else
61 typedef NV VAL64;
62 # define SvVAL64(sv) SvNV (sv)
63 # define newSVval64(i64) newSVnv (i64)
64 #endif
65
66 /* typemap for the above */
67 /*
68 VAL64 T_VAL64
69
70 INPUT
71
72 T_VAL64
73 $var = ($type)SvVAL64 ($arg);
74
75 OUTPUT
76
77 T_VAL64
78 $arg = newSVval64 ($var);
79 */
80
81 /* 5.11 */
82 #ifndef CxHASARGS
83 # define CxHASARGS(cx) (cx)->blk_sub.hasargs
84 #endif
85
86 /* 5.10.0 */
87 #ifndef SvREFCNT_inc_NN
88 # define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv)
89 #endif
90
91 /* 5.8.8 */
92 #ifndef GV_NOTQUAL
93 # define GV_NOTQUAL 0
94 #endif
95 #ifndef newSV
96 # define newSV(l) NEWSV(0,l)
97 #endif
98 #ifndef CvISXSUB_on
99 # define CvISXSUB_on(cv) (void)cv
100 #endif
101 #ifndef CvISXSUB
102 # define CvISXSUB(cv) (CvXSUB (cv) ? TRUE : FALSE)
103 #endif
104 #ifndef Newx
105 # define Newx(ptr,nitems,type) New (0,ptr,nitems,type)
106 #endif
107
108 /* 5.8.7 */
109 #ifndef SvRV_set
110 # define SvRV_set(s,v) SvRV(s) = (v)
111 #endif
112
113 static int
114 s_signum (SV *sig)
115 {
116 #ifndef SIG_SIZE
117 /* kudos to Slaven Rezic for the idea */
118 static char sig_size [] = { SIG_NUM };
119 # define SIG_SIZE (sizeof (sig_size) + 1)
120 #endif
121 dTHX;
122 int signum;
123
124 SvGETMAGIC (sig);
125
126 for (signum = 1; signum < SIG_SIZE; ++signum)
127 if (strEQ (SvPV_nolen (sig), PL_sig_name [signum]))
128 return signum;
129
130 signum = SvIV (sig);
131
132 if (signum > 0 && signum < SIG_SIZE)
133 return signum;
134
135 return -1;
136 }
137
138 static int
139 s_signum_croak (SV *sig)
140 {
141 int signum = s_signum (sig);
142
143 if (signum < 0)
144 {
145 dTHX;
146 croak ("%s: invalid signal name or number", SvPV_nolen (sig));
147 }
148
149 return signum;
150 }
151
152 static int
153 s_fileno (SV *fh, int wr)
154 {
155 dTHX;
156 SvGETMAGIC (fh);
157
158 if (SvROK (fh))
159 {
160 fh = SvRV (fh);
161 SvGETMAGIC (fh);
162 }
163
164 if (SvTYPE (fh) == SVt_PVGV)
165 return PerlIO_fileno (wr ? IoOFP (sv_2io (fh)) : IoIFP (sv_2io (fh)));
166
167 if (SvOK (fh) && (SvIV (fh) >= 0) && (SvIV (fh) < 0x7fffffffL))
168 return SvIV (fh);
169
170 return -1;
171 }
172
173 static int
174 s_fileno_croak (SV *fh, int wr)
175 {
176 int fd = s_fileno (fh, wr);
177
178 if (fd < 0)
179 {
180 dTHX;
181 croak ("%s: illegal fh argument, either not an OS file or read/write mode mismatch", SvPV_nolen (fh));
182 }
183
184 return fd;
185 }
186
187 static SV *
188 s_get_cv (SV *cb_sv)
189 {
190 dTHX;
191 HV *st;
192 GV *gvp;
193
194 return (SV *)sv_2cv (cb_sv, &st, &gvp, 0);
195 }
196
197 static SV *
198 s_get_cv_croak (SV *cb_sv)
199 {
200 SV *cv = s_get_cv (cb_sv);
201
202 if (!cv)
203 {
204 dTHX;
205 croak ("%s: callback must be a CODE reference or another callable object", SvPV_nolen (cb_sv));
206 }
207
208 return cv;
209 }
210
211 /*****************************************************************************/
212 /* gensub: simple closure generation utility */
213
214 #define S_GENSUB_ARG CvXSUBANY (cv).any_ptr
215
216 /* create a closure from XS, returns a code reference */
217 /* the arg can be accessed via GENSUB_ARG from the callback */
218 /* the callback must use dXSARGS/XSRETURN */
219 static SV *
220 s_gensub (pTHX_ void (*xsub)(pTHX_ CV *), void *arg)
221 {
222 CV *cv = (CV *)newSV (0);
223
224 sv_upgrade ((SV *)cv, SVt_PVCV);
225
226 CvANON_on (cv);
227 CvISXSUB_on (cv);
228 CvXSUB (cv) = xsub;
229 S_GENSUB_ARG = arg;
230
231 return newRV_noinc ((SV *)cv);
232 }
233
234 /*****************************************************************************/
235 /* portable pipe/socketpair */
236
237 #ifdef USE_SOCKETS_AS_HANDLES
238 # define S_TO_HANDLE(x) ((HANDLE)win32_get_osfhandle (x))
239 #else
240 # define S_TO_HANDLE(x) ((HANDLE)x)
241 #endif
242
243 #ifdef _WIN32
244 /* taken almost verbatim from libev's ev_win32.c */
245 /* oh, the humanity! */
246 static int
247 s_pipe (int filedes [2])
248 {
249 dTHX;
250
251 struct sockaddr_in addr = { 0 };
252 int addr_size = sizeof (addr);
253 struct sockaddr_in adr2;
254 int adr2_size = sizeof (adr2);
255 SOCKET listener;
256 SOCKET sock [2] = { -1, -1 };
257
258 if ((listener = socket (AF_INET, SOCK_STREAM, 0)) == INVALID_SOCKET)
259 return -1;
260
261 addr.sin_family = AF_INET;
262 addr.sin_addr.s_addr = htonl (INADDR_LOOPBACK);
263 addr.sin_port = 0;
264
265 if (bind (listener, (struct sockaddr *)&addr, addr_size))
266 goto fail;
267
268 if (getsockname (listener, (struct sockaddr *)&addr, &addr_size))
269 goto fail;
270
271 if (listen (listener, 1))
272 goto fail;
273
274 if ((sock [0] = socket (AF_INET, SOCK_STREAM, 0)) == INVALID_SOCKET)
275 goto fail;
276
277 if (connect (sock [0], (struct sockaddr *)&addr, addr_size))
278 goto fail;
279
280 if ((sock [1] = accept (listener, 0, 0)) < 0)
281 goto fail;
282
283 /* windows vista returns fantasy port numbers for getpeername.
284 * example for two interconnected tcp sockets:
285 *
286 * (Socket::unpack_sockaddr_in getsockname $sock0)[0] == 53364
287 * (Socket::unpack_sockaddr_in getpeername $sock0)[0] == 53363
288 * (Socket::unpack_sockaddr_in getsockname $sock1)[0] == 53363
289 * (Socket::unpack_sockaddr_in getpeername $sock1)[0] == 53365
290 *
291 * wow! tridirectional sockets!
292 *
293 * this way of checking ports seems to work:
294 */
295 if (getpeername (sock [0], (struct sockaddr *)&addr, &addr_size))
296 goto fail;
297
298 if (getsockname (sock [1], (struct sockaddr *)&adr2, &adr2_size))
299 goto fail;
300
301 errno = WSAEINVAL;
302 if (addr_size != adr2_size
303 || addr.sin_addr.s_addr != adr2.sin_addr.s_addr /* just to be sure, I mean, it's windows */
304 || addr.sin_port != adr2.sin_port)
305 goto fail;
306
307 closesocket (listener);
308
309 #ifdef USE_SOCKETS_AS_HANDLES
310 /* when select isn't winsocket, we also expect socket, connect, accept etc.
311 * to work on fds */
312 filedes [0] = sock [0];
313 filedes [1] = sock [1];
314 #else
315 filedes [0] = _open_osfhandle (sock [0], 0);
316 filedes [1] = _open_osfhandle (sock [1], 0);
317 #endif
318
319 return 0;
320
321 fail:
322 closesocket (listener);
323
324 if (sock [0] != INVALID_SOCKET) closesocket (sock [0]);
325 if (sock [1] != INVALID_SOCKET) closesocket (sock [1]);
326
327 return -1;
328 }
329
330 #define s_socketpair(domain,type,protocol,filedes) s_pipe (filedes)
331
332 static int
333 s_fd_blocking (int fd, int blocking)
334 {
335 u_long nonblocking = !blocking;
336
337 return ioctlsocket ((SOCKET)S_TO_HANDLE (fd), FIONBIO, &nonblocking);
338 }
339
340 #define s_fd_prepare(fd) s_fd_blocking (fd, 0)
341
342 #else
343
344 #define s_socketpair(domain,type,protocol,filedes) socketpair (domain, type, protocol, filedes)
345 #define s_pipe(filedes) pipe (filedes)
346
347 static int
348 s_fd_blocking (int fd, int blocking)
349 {
350 return fcntl (fd, F_SETFL, blocking ? 0 : O_NONBLOCK);
351 }
352
353 static int
354 s_fd_prepare (int fd)
355 {
356 return s_fd_blocking (fd, 0)
357 || fcntl (fd, F_SETFD, FD_CLOEXEC);
358 }
359
360 #endif
361
362 #if __linux && (__GLIBC__ > 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 7))
363 # define SCHMORP_H_HAVE_EVENTFD 1
364 /* our minimum requirement is glibc 2.7 which has the stub, but not the header */
365 # include <stdint.h>
366 # ifdef __cplusplus
367 extern "C" {
368 # endif
369 int eventfd (unsigned int initval, int flags);
370 # ifdef __cplusplus
371 }
372 # endif
373 #else
374 # define eventfd(initval,flags) -1
375 #endif
376
377 typedef struct {
378 int fd[2]; /* read, write fd, might be equal */
379 int len; /* write length (1 pipe/socket, 8 eventfd) */
380 } s_epipe;
381
382 static int
383 s_epipe_new (s_epipe *epp)
384 {
385 s_epipe ep;
386
387 ep.fd [0] = ep.fd [1] = eventfd (0, 0);
388
389 if (ep.fd [0] >= 0)
390 {
391 s_fd_prepare (ep.fd [0]);
392 ep.len = 8;
393 }
394 else
395 {
396 if (s_pipe (ep.fd))
397 return -1;
398
399 if (s_fd_prepare (ep.fd [0])
400 || s_fd_prepare (ep.fd [1]))
401 {
402 dTHX;
403
404 close (ep.fd [0]);
405 close (ep.fd [1]);
406 return -1;
407 }
408
409 ep.len = 1;
410 }
411
412 *epp = ep;
413 return 0;
414 }
415
416 static void
417 s_epipe_destroy (s_epipe *epp)
418 {
419 dTHX;
420
421 close (epp->fd [0]);
422
423 if (epp->fd [1] != epp->fd [0])
424 close (epp->fd [1]);
425
426 epp->len = 0;
427 }
428
429 static void
430 s_epipe_signal (s_epipe *epp)
431 {
432 #ifdef _WIN32
433 /* perl overrides send with a function that crashes in other threads.
434 * unfortunately, it overrides it with an argument-less macro, so
435 * there is no way to force usage of the real send function.
436 * incompetent windows programmers - is this redundant?
437 */
438 DWORD dummy;
439 WriteFile (S_TO_HANDLE (epp->fd [1]), (LPCVOID)&dummy, 1, &dummy, 0);
440 #else
441 # if SCHMORP_H_HAVE_EVENTFD
442 static uint64_t counter = 1;
443 # else
444 static char counter [8];
445 # endif
446 /* some modules accept fd's from outside, support eventfd here */
447 if (write (epp->fd [1], &counter, epp->len) < 0
448 && errno == EINVAL
449 && epp->len != 8)
450 write (epp->fd [1], &counter, (epp->len = 8));
451 #endif
452 }
453
454 static void
455 s_epipe_drain (s_epipe *epp)
456 {
457 dTHX;
458 char buf [9];
459
460 #ifdef _WIN32
461 recv (epp->fd [0], buf, sizeof (buf), 0);
462 #else
463 read (epp->fd [0], buf, sizeof (buf));
464 #endif
465 }
466
467 /* like new, but dups over old */
468 static int
469 s_epipe_renew (s_epipe *epp)
470 {
471 dTHX;
472 s_epipe epn;
473
474 if (epp->fd [1] != epp->fd [0])
475 close (epp->fd [1]);
476
477 if (s_epipe_new (&epn))
478 return -1;
479
480 if (epp->len)
481 {
482 if (dup2 (epn.fd [0], epp->fd [0]) < 0)
483 croak ("unable to dup over old event pipe"); /* should not croak */
484
485 close (epn.fd [0]);
486
487 if (epn.fd [0] == epn.fd [1])
488 epn.fd [1] = epp->fd [0];
489
490 epn.fd [0] = epp->fd [0];
491 }
492
493 *epp = epn;
494
495 return 0;
496 }
497
498 #define s_epipe_fd(epp) ((epp)->fd [0])
499
500 static int
501 s_epipe_wait (s_epipe *epp)
502 {
503 dTHX;
504 #if SCHMORP_H_PREFER_SELECT
505 fd_set rfd;
506 int fd = s_epipe_fd (epp);
507
508 FD_ZERO (&rfd);
509 FD_SET (fd, &rfd);
510
511 return PerlSock_select (fd + 1, &rfd, 0, 0, 0);
512 #else
513 /* poll is preferable on posix systems */
514 struct pollfd pfd;
515
516 pfd.fd = s_epipe_fd (epp);
517 pfd.events = POLLIN;
518
519 return poll (&pfd, 1, -1);
520 #endif
521 }
522
523 #endif
524