This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make the isdst argument to asctime and mktime default to -1
[perl5.git] / ext / threads / shared / shared.xs
CommitLineData
afe38520 1/* shared.xs
68795e93 2 *
60c5c75c 3 * Copyright (c) 2001-2002, 2006 Larry Wall
68795e93
NIS
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
21312124
NIS
8 * "Hand any two wizards a piece of rope and they would instinctively pull in
9 * opposite directions."
10 * --Sourcery
11 *
7473853a
SP
12 * Contributed by Artur Bergman <sky AT crucially DOT net>
13 * Pulled in the (an)other direction by Nick Ing-Simmons
14 * <nick AT ing-simmons DOT net>
15 * CPAN version produced by Jerry D. Hedden <jdhedden AT cpan DOT org>
21312124 16 */
68795e93 17
29ecdb6f
DM
18/*
19 * Shared variables are implemented by a scheme similar to tieing.
20 * Each thread has a proxy SV with attached magic -- "private SVs" --
21 * which all point to a single SV in a separate shared interpreter
22 * (PL_sharedsv_space) -- "shared SVs".
23 *
24 * The shared SV holds the variable's true values, and its state is
25 * copied between the shared and private SVs with the usual
26 * mg_get()/mg_set() arrangement.
27 *
28 * Aggregates (AVs and HVs) are implemented using tie magic, except that
29 * the vtable used is one defined in this file rather than the standard one.
7473853a 30 * This means that where a tie function like FETCH is normally invoked by
29ecdb6f
DM
31 * the tie magic's mg_get() function, we completely bypass the calling of a
32 * perl-level function, and directly call C-level code to handle it. On
7473853a
SP
33 * the other hand, calls to functions like PUSH are done directly by code
34 * in av.c, etc., which we can't bypass. So the best we can do is to provide
29ecdb6f
DM
35 * XS versions of these functions. We also have to attach a tie object,
36 * blessed into the class threads::shared::tie, to keep the method-calling
37 * code happy.
38 *
39 * Access to aggregate elements is done the usual tied way by returning a
40 * proxy PVLV element with attached element magic.
41 *
42 * Pointers to the shared SV are squirrelled away in the mg->mg_ptr field
43 * of magic (with mg_len == 0), and in the IV2PTR(SvIV(sv)) field of tied
44 * object SVs. These pointers have to be hidden like this because they
45 * cross interpreter boundaries, and we don't want sv_clear() and friends
46 * following them.
47 *
48 * The three basic shared types look like the following:
49 *
50 * -----------------
51 *
52 * Shared scalar (my $s : shared):
53 *
54 * SV = PVMG(0x7ba238) at 0x7387a8
55 * FLAGS = (PADMY,GMG,SMG)
56 * MAGIC = 0x824d88
57 * MG_TYPE = PERL_MAGIC_shared_scalar(n)
7473853a 58 * MG_PTR = 0x810358 <<<< pointer to the shared SV
29ecdb6f
DM
59 *
60 * -----------------
61 *
62 * Shared aggregate (my @a : shared; my %h : shared):
63 *
64 * SV = PVAV(0x7175d0) at 0x738708
65 * FLAGS = (PADMY,RMG)
66 * MAGIC = 0x824e48
67 * MG_TYPE = PERL_MAGIC_tied(P)
7473853a 68 * MG_OBJ = 0x7136e0 <<<< ref to the tied object
29ecdb6f
DM
69 * SV = RV(0x7136f0) at 0x7136e0
70 * RV = 0x738640
71 * SV = PVMG(0x7ba238) at 0x738640 <<<< the tied object
72 * FLAGS = (OBJECT,IOK,pIOK)
7473853a 73 * IV = 8455000 <<<< pointer to the shared AV
29ecdb6f 74 * STASH = 0x80abf0 "threads::shared::tie"
7473853a 75 * MG_PTR = 0x810358 "" <<<< another pointer to the shared AV
29ecdb6f
DM
76 * ARRAY = 0x0
77 *
78 * -----------------
79 *
80 * Aggregate element (my @a : shared; $a[0])
81 *
82 * SV = PVLV(0x77f628) at 0x713550
83 * FLAGS = (GMG,SMG,RMG,pIOK)
84 * MAGIC = 0x72bd58
85 * MG_TYPE = PERL_MAGIC_shared_scalar(n)
7473853a 86 * MG_PTR = 0x8103c0 "" <<<< pointer to the shared element
29ecdb6f
DM
87 * MAGIC = 0x72bd18
88 * MG_TYPE = PERL_MAGIC_tiedelem(p)
7473853a 89 * MG_OBJ = 0x7136e0 <<<< ref to the tied object
29ecdb6f
DM
90 * SV = RV(0x7136f0) at 0x7136e0
91 * RV = 0x738660
92 * SV = PVMG(0x7ba278) at 0x738660 <<<< the tied object
93 * FLAGS = (OBJECT,IOK,pIOK)
7473853a 94 * IV = 8455064 <<<< pointer to the shared AV
29ecdb6f
DM
95 * STASH = 0x80ac30 "threads::shared::tie"
96 * TYPE = t
97 *
98 * Note that PERL_MAGIC_tiedelem(p) magic doesn't have a pointer to a
99 * shared SV in mg_ptr; instead this is used to store the hash key,
100 * if any, like normal tied elements. Note also that element SVs may have
7473853a 101 * pointers to both the shared aggregate and the shared element.
29ecdb6f
DM
102 *
103 *
104 * Userland locks:
105 *
7473853a 106 * If a shared variable is used as a perl-level lock or condition
29ecdb6f 107 * variable, then PERL_MAGIC_ext magic is attached to the associated
7473853a 108 * *shared* SV, whose mg_ptr field points to a malloc'ed structure
29ecdb6f
DM
109 * containing the necessary mutexes and condition variables.
110 *
111 * Nomenclature:
112 *
7473853a
SP
113 * In this file, any variable name prefixed with 's' (e.g., ssv, stmp or sobj)
114 * usually represents a shared SV which corresponds to a private SV named
115 * without the prefix (e.g., sv, tmp or obj).
116 */
117
118/* Patch status:
119 *
120 * Perl 5.8.8 contains threads::shared patches up to 26626 (equivalent to
121 * blead patches 26350+26351).
122 *
123 * The CPAN version of threads::shared contains the following blead patches:
124 * 26569 (applicable to 5.9.3 only)
125 * 26684
126 * 26693
127 * 26695
29ecdb6f
DM
128 */
129
68795e93 130#define PERL_NO_GET_CONTEXT
b050c948
AB
131#include "EXTERN.h"
132#include "perl.h"
133#include "XSUB.h"
7473853a
SP
134#ifdef HAS_PPPORT_H
135#define NEED_vnewSVpvf
136#define NEED_warner
137# include "ppport.h"
138# include "shared.h"
139#endif
b050c948 140
73e09c8f
JH
141#ifdef USE_ITHREADS
142
21312124
NIS
143/*
144 * The shared things need an intepreter to live in ...
145 */
146PerlInterpreter *PL_sharedsv_space; /* The shared sv space */
147/* To access shared space we fake aTHX in this scope and thread's context */
057e91b3 148
7473853a
SP
149/* Bug #24255: We include ENTER+SAVETMPS/FREETMPS+LEAVE with
150 * SHARED_CONTEXT/CALLER_CONTEXT macros, so that any mortals, etc. created
1011f542 151 * while in the shared interpreter context don't languish */
057e91b3 152
7473853a
SP
153#define SHARED_CONTEXT \
154 STMT_START { \
155 PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); \
156 ENTER; \
157 SAVETMPS; \
057e91b3 158 } STMT_END
21312124
NIS
159
160/* So we need a way to switch back to the caller's context... */
161/* So we declare _another_ copy of the aTHX variable ... */
162#define dTHXc PerlInterpreter *caller_perl = aTHX
057e91b3 163
7473853a
SP
164/* ... and use it to switch back */
165#define CALLER_CONTEXT \
166 STMT_START { \
167 FREETMPS; \
168 LEAVE; \
169 PERL_SET_CONTEXT((aTHX = caller_perl)); \
057e91b3 170 } STMT_END
21312124
NIS
171
172/*
173 * Only one thread at a time is allowed to mess with shared space.
174 */
a446a88f 175
7473853a
SP
176typedef struct {
177 perl_mutex mutex;
178 PerlInterpreter *owner;
179 I32 locks;
180 perl_cond cond;
6b85e4fe 181#ifdef DEBUG_LOCKS
7473853a
SP
182 char * file;
183 int line;
6b85e4fe 184#endif
6d56dc1c
NIS
185} recursive_lock_t;
186
7473853a 187recursive_lock_t PL_sharedsv_lock; /* Mutex protecting the shared sv space */
6d56dc1c
NIS
188
189void
190recursive_lock_init(pTHX_ recursive_lock_t *lock)
191{
192 Zero(lock,1,recursive_lock_t);
193 MUTEX_INIT(&lock->mutex);
194 COND_INIT(&lock->cond);
195}
196
a39edb3a 197void
579f9913
AB
198recursive_lock_destroy(pTHX_ recursive_lock_t *lock)
199{
200 MUTEX_DESTROY(&lock->mutex);
201 COND_DESTROY(&lock->cond);
202}
203
6d56dc1c
NIS
204void
205recursive_lock_release(pTHX_ recursive_lock_t *lock)
206{
207 MUTEX_LOCK(&lock->mutex);
ba2940ce
JH
208 if (lock->owner == aTHX) {
209 if (--lock->locks == 0) {
210 lock->owner = NULL;
211 COND_SIGNAL(&lock->cond);
212 }
6d56dc1c
NIS
213 }
214 MUTEX_UNLOCK(&lock->mutex);
215}
a446a88f 216
6d56dc1c 217void
7473853a 218recursive_lock_acquire(pTHX_ recursive_lock_t *lock, char *file, int line)
6d56dc1c
NIS
219{
220 assert(aTHX);
221 MUTEX_LOCK(&lock->mutex);
222 if (lock->owner == aTHX) {
7473853a
SP
223 lock->locks++;
224 } else {
225 while (lock->owner) {
6b85e4fe 226#ifdef DEBUG_LOCKS
7473853a
SP
227 Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n",
228 aTHX, lock->owner, lock->file, lock->line);
6b85e4fe 229#endif
7473853a 230 COND_WAIT(&lock->cond,&lock->mutex);
6b85e4fe 231 }
7473853a
SP
232 lock->locks = 1;
233 lock->owner = aTHX;
6b85e4fe 234#ifdef DEBUG_LOCKS
7473853a
SP
235 lock->file = file;
236 lock->line = line;
6b85e4fe 237#endif
6d56dc1c
NIS
238 }
239 MUTEX_UNLOCK(&lock->mutex);
6b85e4fe 240 SAVEDESTRUCTOR_X(recursive_lock_release,lock);
6d56dc1c
NIS
241}
242
7473853a
SP
243#define ENTER_LOCK \
244 STMT_START { \
245 ENTER; \
246 recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__);\
247 } STMT_END
21312124 248
7473853a
SP
249/* The unlocking is done automatically at scope exit */
250#define LEAVE_LOCK LEAVE
6d56dc1c 251
21312124
NIS
252
253/* A common idiom is to acquire access and switch in ... */
7473853a
SP
254#define SHARED_EDIT \
255 STMT_START { \
256 ENTER_LOCK; \
257 SHARED_CONTEXT; \
258 } STMT_END
21312124 259
7473853a
SP
260/* ... then switch out and release access. */
261#define SHARED_RELEASE \
262 STMT_START { \
263 CALLER_CONTEXT; \
264 LEAVE_LOCK; \
265 } STMT_END
85e0a142 266
21312124 267
7473853a 268/* User-level locks:
29ecdb6f
DM
269 This structure is attached (using ext magic) to any shared SV that
270 is used by user-level locking or condition code
21312124 271*/
68795e93
NIS
272
273typedef struct {
7473853a 274 recursive_lock_t lock; /* For user-levl locks */
68795e93 275 perl_cond user_cond; /* For user-level conditions */
29ecdb6f 276} user_lock;
68795e93 277
7473853a 278/* Magic used for attaching user_lock structs to shared SVs
68795e93 279
21312124
NIS
280 The vtable used has just one entry - when the SV goes away
281 we free the memory for the above.
21312124 282 */
68795e93 283
21312124 284int
29ecdb6f 285sharedsv_userlock_free(pTHX_ SV *sv, MAGIC *mg)
21312124 286{
29ecdb6f
DM
287 user_lock *ul = (user_lock *) mg->mg_ptr;
288 assert(aTHX == PL_sharedsv_space);
289 if (ul) {
7473853a
SP
290 recursive_lock_destroy(aTHX_ &ul->lock);
291 COND_DESTROY(&ul->user_cond);
292 PerlMemShared_free(ul);
293 mg->mg_ptr = NULL;
21312124 294 }
7473853a 295 return (0);
21312124
NIS
296}
297
7473853a
SP
298MGVTBL sharedsv_userlock_vtbl = {
299 0, /* get */
300 0, /* set */
301 0, /* len */
302 0, /* clear */
303 sharedsv_userlock_free, /* free */
304 0, /* copy */
305 0, /* dup */
306#ifdef MGf_LOCAL
307 0, /* local */
308#endif
21312124
NIS
309};
310
7473853a
SP
311/*
312 * Access to shared things is heavily based on MAGIC
313 * - in mg.h/mg.c/sv.c sense
314 */
21312124
NIS
315
316/* In any thread that has access to a shared thing there is a "proxy"
317 for it in its own space which has 'MAGIC' associated which accesses
318 the shared thing.
319 */
320
3bc7ad01
JH
321extern MGVTBL sharedsv_scalar_vtbl; /* Scalars have this vtable */
322extern MGVTBL sharedsv_array_vtbl; /* Hashes and arrays have this
323 - like 'tie' */
324extern MGVTBL sharedsv_elem_vtbl; /* Elements of hashes and arrays have
325 this _AS WELL AS_ the scalar magic:
29ecdb6f 326 The sharedsv_elem_vtbl associates the element with the array/hash and
21312124
NIS
327 the sharedsv_scalar_vtbl associates it with the value
328 */
329
6b85e4fe 330
7473853a 331/* Get shared aggregate SV pointed to by threads::shared::tie magic object */
29ecdb6f
DM
332
333STATIC SV *
334S_sharedsv_from_obj(pTHX_ SV *sv)
6b85e4fe 335{
7473853a 336 return ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL);
29ecdb6f
DM
337}
338
339
340/* Return the user_lock structure (if any) associated with a shared SV.
7473853a
SP
341 * If create is true, create one if it doesn't exist
342 */
29ecdb6f
DM
343STATIC user_lock *
344S_get_userlock(pTHX_ SV* ssv, bool create)
345{
346 MAGIC *mg;
347 user_lock *ul = NULL;
348
349 assert(ssv);
7473853a 350 /* XXX Redesign the storage of user locks so we don't need a global
29ecdb6f
DM
351 * lock to access them ???? DAPM */
352 ENTER_LOCK;
353 mg = mg_find(ssv, PERL_MAGIC_ext);
7473853a
SP
354 if (mg) {
355 ul = (user_lock*)(mg->mg_ptr);
356 } else if (create) {
357 dTHXc;
358 SHARED_CONTEXT;
359 ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock));
360 Zero(ul, 1, user_lock);
361 /* Attach to shared SV using ext magic */
362 sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl,
363 (char *)ul, 0);
364 recursive_lock_init(aTHX_ &ul->lock);
365 COND_INIT(&ul->user_cond);
366 CALLER_CONTEXT;
29ecdb6f
DM
367 }
368 LEAVE_LOCK;
7473853a 369 return (ul);
6b85e4fe
NIS
370}
371
29ecdb6f 372
ba2940ce
JH
373/* Given a private side SV tries to find if the SV has a shared backend,
374 * by looking for the magic.
375 */
29ecdb6f 376SV *
21312124
NIS
377Perl_sharedsv_find(pTHX_ SV *sv)
378{
379 MAGIC *mg;
a446a88f 380 if (SvTYPE(sv) >= SVt_PVMG) {
7473853a
SP
381 switch(SvTYPE(sv)) {
382 case SVt_PVAV:
383 case SVt_PVHV:
384 if ((mg = mg_find(sv, PERL_MAGIC_tied))
385 && mg->mg_virtual == &sharedsv_array_vtbl) {
386 return ((SV *)mg->mg_ptr);
387 }
388 break;
389 default:
390 /* This should work for elements as well as they
391 * have scalar magic as well as their element magic
392 */
393 if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar))
394 && mg->mg_virtual == &sharedsv_scalar_vtbl) {
395 return ((SV *)mg->mg_ptr);
396 }
397 break;
398 }
21312124 399 }
6b85e4fe
NIS
400 /* Just for tidyness of API also handle tie objects */
401 if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) {
7473853a 402 return (S_sharedsv_from_obj(aTHX_ sv));
6b85e4fe 403 }
7473853a 404 return (NULL);
21312124 405}
68795e93 406
68795e93 407
7473853a
SP
408/* Associate a private SV with a shared SV by pointing the appropriate
409 * magics at it.
410 * Assumes lock is held.
411 */
29ecdb6f
DM
412void
413Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv)
21312124 414{
21312124 415 dTHXc;
a446a88f 416 MAGIC *mg = 0;
a446a88f 417
29ecdb6f 418 /* If we are asked for any private ops we need a thread */
a446a88f
NIS
419 assert ( aTHX != PL_sharedsv_space );
420
421 /* To avoid need for recursive locks require caller to hold lock */
6d56dc1c 422 assert ( PL_sharedsv_lock.owner == aTHX );
6b85e4fe 423
29ecdb6f
DM
424 switch(SvTYPE(sv)) {
425 case SVt_PVAV:
426 case SVt_PVHV:
7473853a
SP
427 if (!(mg = mg_find(sv, PERL_MAGIC_tied))
428 || mg->mg_virtual != &sharedsv_array_vtbl
429 || (SV*) mg->mg_ptr != ssv)
430 {
431 SV *obj = newSV(0);
432 sv_setref_iv(obj, "threads::shared::tie", PTR2IV(ssv));
433 if (mg) {
434 sv_unmagic(sv, PERL_MAGIC_tied);
435 }
436 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
437 (char *)ssv, 0);
438 mg->mg_flags |= (MGf_COPY|MGf_DUP);
439 SvREFCNT_inc_void(ssv);
440 SvREFCNT_dec(obj);
441 }
442 break;
68795e93 443
29ecdb6f 444 default:
7473853a
SP
445 if ((SvTYPE(sv) < SVt_PVMG)
446 || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar))
447 || mg->mg_virtual != &sharedsv_scalar_vtbl
448 || (SV*) mg->mg_ptr != ssv)
449 {
450 if (mg) {
451 sv_unmagic(sv, PERL_MAGIC_shared_scalar);
452 }
453 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
454 &sharedsv_scalar_vtbl, (char *)ssv, 0);
455 mg->mg_flags |= (MGf_DUP
456#ifdef MGf_LOCAL
457 |MGf_LOCAL
458#endif
459 );
460 SvREFCNT_inc_void(ssv);
461 }
462 break;
21312124 463 }
7473853a 464
29ecdb6f
DM
465 assert ( Perl_sharedsv_find(aTHX_ sv) == ssv );
466}
6b85e4fe 467
6b85e4fe 468
29ecdb6f 469/* Given a private SV, create and return an associated shared SV.
7473853a
SP
470 * Assumes lock is held.
471 */
29ecdb6f
DM
472STATIC SV *
473S_sharedsv_new_shared(pTHX_ SV *sv)
474{
475 dTHXc;
476 SV *ssv;
6b85e4fe 477
29ecdb6f
DM
478 assert(PL_sharedsv_lock.owner == aTHX);
479 assert(aTHX != PL_sharedsv_space);
68795e93 480
29ecdb6f
DM
481 SHARED_CONTEXT;
482 ssv = newSV(0);
7473853a 483 SvREFCNT(ssv) = 0; /* Will be upped to 1 by Perl_sharedsv_associate */
29ecdb6f
DM
484 sv_upgrade(ssv, SvTYPE(sv));
485 CALLER_CONTEXT;
486 Perl_sharedsv_associate(aTHX_ sv, ssv);
7473853a 487 return (ssv);
29ecdb6f 488}
21312124 489
21312124 490
29ecdb6f 491/* Given a shared SV, create and return an associated private SV.
7473853a
SP
492 * Assumes lock is held.
493 */
29ecdb6f
DM
494STATIC SV *
495S_sharedsv_new_private(pTHX_ SV *ssv)
496{
497 SV *sv;
498
499 assert(PL_sharedsv_lock.owner == aTHX);
500 assert(aTHX != PL_sharedsv_space);
501
502 sv = newSV(0);
503 sv_upgrade(sv, SvTYPE(ssv));
504 Perl_sharedsv_associate(aTHX_ sv, ssv);
7473853a 505 return (sv);
21312124 506}
68795e93 507
29ecdb6f 508
7473853a 509/* A threadsafe version of SvREFCNT_dec(ssv) */
29ecdb6f
DM
510
511STATIC void
512S_sharedsv_dec(pTHX_ SV* ssv)
68795e93 513{
7473853a
SP
514 if (! ssv)
515 return;
29ecdb6f
DM
516 ENTER_LOCK;
517 if (SvREFCNT(ssv) > 1) {
7473853a
SP
518 /* No side effects, so can do it lightweight */
519 SvREFCNT_dec(ssv);
520 } else {
521 dTHXc;
522 SHARED_CONTEXT;
523 SvREFCNT_dec(ssv);
524 CALLER_CONTEXT;
21312124 525 }
29ecdb6f 526 LEAVE_LOCK;
68795e93
NIS
527}
528
7473853a
SP
529
530/* Implements Perl-level share() and :shared */
29ecdb6f 531
21312124
NIS
532void
533Perl_sharedsv_share(pTHX_ SV *sv)
534{
535 switch(SvTYPE(sv)) {
536 case SVt_PVGV:
7473853a
SP
537 Perl_croak(aTHX_ "Cannot share globs yet");
538 break;
21312124
NIS
539
540 case SVt_PVCV:
7473853a
SP
541 Perl_croak(aTHX_ "Cannot share subs yet");
542 break;
85e0a142 543
21312124 544 default:
7473853a
SP
545 ENTER_LOCK;
546 (void) S_sharedsv_new_shared(aTHX_ sv);
547 LEAVE_LOCK;
548 SvSETMAGIC(sv);
549 break;
21312124
NIS
550 }
551}
68795e93 552
7473853a 553
a0e036c1 554#if defined(WIN32) || defined(OS2)
7473853a 555# define ABS2RELMILLI(abs) \
a0e036c1 556 do { \
2666606c 557 abs -= (double)time(NULL); \
a0e036c1
MP
558 if (abs > 0) { abs *= 1000; } \
559 else { abs = 0; } \
560 } while (0)
561#endif /* WIN32 || OS2 */
562
7473853a 563/* Do OS-specific condition timed wait */
29ecdb6f 564
a0e036c1
MP
565bool
566Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs)
567{
568#if defined(NETWARE) || defined(FAKE_THREADS) || defined(I_MACH_CTHREADS)
569 Perl_croak_nocontext("cond_timedwait not supported on this platform");
570#else
571# ifdef WIN32
572 int got_it = 0;
573
574 ABS2RELMILLI(abs);
575
576 cond->waiters++;
577 MUTEX_UNLOCK(mut);
578 /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */
028f8eaa 579 switch (WaitForSingleObject(cond->sem, (DWORD)abs)) {
a0e036c1
MP
580 case WAIT_OBJECT_0: got_it = 1; break;
581 case WAIT_TIMEOUT: break;
582 default:
583 /* WAIT_FAILED? WAIT_ABANDONED? others? */
584 Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError());
585 break;
586 }
587 MUTEX_LOCK(mut);
2666606c 588 cond->waiters--;
7473853a 589 return (got_it);
a0e036c1
MP
590# else
591# ifdef OS2
592 int rc, got_it = 0;
593 STRLEN n_a;
594
595 ABS2RELMILLI(abs);
596
597 if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET))
598 Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset");
599 MUTEX_UNLOCK(mut);
600 if (CheckOSError(DosWaitEventSem(*cond,abs))
601 && (rc != ERROR_INTERRUPT))
602 croak_with_os2error("panic: cond_timedwait");
603 if (rc == ERROR_INTERRUPT) errno = EINTR;
604 MUTEX_LOCK(mut);
7473853a
SP
605 return (got_it);
606# else /* Hope you're I_PTHREAD! */
a0e036c1
MP
607 struct timespec ts;
608 int got_it = 0;
609
610 ts.tv_sec = (long)abs;
611 abs -= (NV)ts.tv_sec;
612 ts.tv_nsec = (long)(abs * 1000000000.0);
613
614 switch (pthread_cond_timedwait(cond, mut, &ts)) {
615 case 0: got_it = 1; break;
616 case ETIMEDOUT: break;
cf0d1c66
JH
617#ifdef OEMVS
618 case -1:
7473853a
SP
619 if (errno == ETIMEDOUT || errno == EAGAIN)
620 break;
cf0d1c66 621#endif
a0e036c1
MP
622 default:
623 Perl_croak_nocontext("panic: cond_timedwait");
624 break;
625 }
7473853a 626 return (got_it);
a0e036c1
MP
627# endif /* OS2 */
628# endif /* WIN32 */
629#endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */
630}
631
dad67c22 632
7473853a 633/* Given a shared RV, copy it's value to a private RV, also copying the
dad67c22
DM
634 * object status of the referent.
635 * If the private side is already an appropriate RV->SV combination, keep
636 * it if possible.
637 */
dad67c22
DM
638STATIC void
639S_get_RV(pTHX_ SV *sv, SV *ssv) {
640 SV *sobj = SvRV(ssv);
641 SV *obj;
7473853a
SP
642 if (! (SvROK(sv) &&
643 ((obj = SvRV(sv))) &&
644 (Perl_sharedsv_find(aTHX_ obj) == sobj) &&
645 (SvTYPE(obj) == SvTYPE(sobj))))
dad67c22 646 {
7473853a
SP
647 /* Can't reuse obj */
648 if (SvROK(sv)) {
649 SvREFCNT_dec(SvRV(sv));
650 } else {
651 assert(SvTYPE(sv) >= SVt_RV);
652 sv_setsv_nomg(sv, &PL_sv_undef);
653 SvROK_on(sv);
654 }
655 obj = S_sharedsv_new_private(aTHX_ SvRV(ssv));
656 SvRV_set(sv, obj);
dad67c22
DM
657 }
658
659 if (SvOBJECT(obj)) {
7473853a
SP
660 /* Remove any old blessing */
661 SvREFCNT_dec(SvSTASH(obj));
662 SvOBJECT_off(obj);
dad67c22
DM
663 }
664 if (SvOBJECT(sobj)) {
7473853a
SP
665 /* Add any new old blessing */
666 STRLEN len;
667 char* stash_ptr = SvPV((SV*) SvSTASH(sobj), len);
668 HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
669 SvOBJECT_on(obj);
670 SvSTASH_set(obj, (HV*)SvREFCNT_inc(stash));
dad67c22
DM
671 }
672}
673
674
29ecdb6f
DM
675/* ------------ PERL_MAGIC_shared_scalar(n) functions -------------- */
676
7473853a 677/* Get magic for PERL_MAGIC_shared_scalar(n) */
68795e93 678
21312124
NIS
679int
680sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
68795e93 681{
29ecdb6f
DM
682 SV *ssv = (SV *) mg->mg_ptr;
683 assert(ssv);
21312124 684
6d56dc1c 685 ENTER_LOCK;
29ecdb6f 686 if (SvROK(ssv)) {
7473853a
SP
687 S_get_RV(aTHX_ sv, ssv);
688 } else {
689 sv_setsv_nomg(sv, ssv);
21312124 690 }
6d56dc1c 691 LEAVE_LOCK;
7473853a 692 return (0);
21312124
NIS
693}
694
7473853a
SP
695/* Copy the contents of a private SV to a shared SV.
696 * Used by various mg_set()-type functions.
697 * Assumes lock is held.
698 */
6b85e4fe 699void
29ecdb6f 700sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv)
21312124
NIS
701{
702 dTHXc;
21312124 703 bool allowed = TRUE;
29ecdb6f
DM
704
705 assert(PL_sharedsv_lock.owner == aTHX);
21312124 706 if (SvROK(sv)) {
7473853a
SP
707 SV *obj = SvRV(sv);
708 SV *sobj = Perl_sharedsv_find(aTHX_ obj);
709 if (sobj) {
710 SHARED_CONTEXT;
711 SvUPGRADE(ssv, SVt_RV);
712 sv_setsv_nomg(ssv, &PL_sv_undef);
713
714 SvRV_set(ssv, SvREFCNT_inc(sobj));
715 SvROK_on(ssv);
716 if (SvOBJECT(sobj)) {
717 /* Remove any old blessing */
718 SvREFCNT_dec(SvSTASH(sobj));
719 SvOBJECT_off(sobj);
720 }
721 if (SvOBJECT(obj)) {
722 SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(obj)),0);
723 SvOBJECT_on(sobj);
724 SvSTASH_set(sobj, (HV*)fake_stash);
725 }
726 CALLER_CONTEXT;
727 } else {
728 allowed = FALSE;
729 }
730 } else {
5c360ac5 731 SvTEMP_off(sv);
7473853a
SP
732 SHARED_CONTEXT;
733 sv_setsv_nomg(ssv, sv);
734 if (SvOBJECT(ssv)) {
735 /* Remove any old blessing */
736 SvREFCNT_dec(SvSTASH(ssv));
737 SvOBJECT_off(ssv);
738 }
739 if (SvOBJECT(sv)) {
740 SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0);
741 SvOBJECT_on(ssv);
742 SvSTASH_set(ssv, (HV*)fake_stash);
743 }
744 CALLER_CONTEXT;
21312124 745 }
21312124 746 if (!allowed) {
7473853a 747 Perl_croak(aTHX_ "Invalid value for shared scalar");
21312124 748 }
6b85e4fe
NIS
749}
750
7473853a 751/* Set magic for PERL_MAGIC_shared_scalar(n) */
29ecdb6f 752
6b85e4fe
NIS
753int
754sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
755{
29ecdb6f
DM
756 SV *ssv = (SV*)(mg->mg_ptr);
757 assert(ssv);
6b85e4fe 758 ENTER_LOCK;
29ecdb6f 759 if (SvTYPE(ssv) < SvTYPE(sv)) {
7473853a
SP
760 dTHXc;
761 SHARED_CONTEXT;
762 sv_upgrade(ssv, SvTYPE(sv));
763 CALLER_CONTEXT;
29ecdb6f
DM
764 }
765 sharedsv_scalar_store(aTHX_ sv, ssv);
6b85e4fe 766 LEAVE_LOCK;
7473853a 767 return (0);
68795e93
NIS
768}
769
7473853a 770/* Free magic for PERL_MAGIC_shared_scalar(n) */
a446a88f
NIS
771
772int
29ecdb6f 773sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
a446a88f 774{
29ecdb6f 775 S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr);
7473853a 776 return (0);
21312124 777}
68795e93
NIS
778
779/*
29ecdb6f 780 * Called during cloning of PERL_MAGIC_shared_scalar(n) magic in new thread
21312124
NIS
781 */
782int
783sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
784{
7473853a
SP
785 SvREFCNT_inc_void(mg->mg_ptr);
786 return (0);
21312124 787}
68795e93 788
7473853a 789#ifdef MGf_LOCAL
a5063e7c
DM
790/*
791 * Called during local $shared
792 */
793int
794sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg)
795{
796 MAGIC *nmg;
29ecdb6f
DM
797 SV *ssv = (SV *) mg->mg_ptr;
798 if (ssv) {
7473853a
SP
799 ENTER_LOCK;
800 SvREFCNT_inc_void(ssv);
801 LEAVE_LOCK;
a5063e7c
DM
802 }
803 nmg = sv_magicext(nsv, mg->mg_obj, mg->mg_type, mg->mg_virtual,
7473853a 804 mg->mg_ptr, mg->mg_len);
a5063e7c
DM
805 nmg->mg_flags = mg->mg_flags;
806 nmg->mg_private = mg->mg_private;
807
7473853a 808 return (0);
a5063e7c 809}
7473853a 810#endif
a5063e7c 811
21312124 812MGVTBL sharedsv_scalar_vtbl = {
7473853a
SP
813 sharedsv_scalar_mg_get, /* get */
814 sharedsv_scalar_mg_set, /* set */
815 0, /* len */
816 0, /* clear */
817 sharedsv_scalar_mg_free, /* free */
818 0, /* copy */
819 sharedsv_scalar_mg_dup, /* dup */
820#ifdef MGf_LOCAL
821 sharedsv_scalar_mg_local, /* local */
822#endif
21312124 823};
68795e93 824
29ecdb6f
DM
825/* ------------ PERL_MAGIC_tiedelem(p) functions -------------- */
826
7473853a 827/* Get magic for PERL_MAGIC_tiedelem(p) */
29ecdb6f 828
21312124
NIS
829int
830sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
68795e93 831{
21312124 832 dTHXc;
29ecdb6f 833 SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
21312124
NIS
834 SV** svp;
835
6b85e4fe 836 ENTER_LOCK;
29ecdb6f 837 if (SvTYPE(saggregate) == SVt_PVAV) {
7473853a
SP
838 assert ( mg->mg_ptr == 0 );
839 SHARED_CONTEXT;
840 svp = av_fetch((AV*) saggregate, mg->mg_len, 0);
841 } else {
842 char *key = mg->mg_ptr;
843 STRLEN len = mg->mg_len;
844 assert ( mg->mg_ptr != 0 );
845 if (mg->mg_len == HEf_SVKEY) {
846 key = SvPV((SV *) mg->mg_ptr, len);
847 }
848 SHARED_CONTEXT;
849 svp = hv_fetch((HV*) saggregate, key, len, 0);
21312124 850 }
6b85e4fe 851 CALLER_CONTEXT;
21312124 852 if (svp) {
7473853a
SP
853 /* Exists in the array */
854 if (SvROK(*svp)) {
855 S_get_RV(aTHX_ sv, *svp);
856 } else {
857 /* XXX Can this branch ever happen? DAPM */
858 /* XXX assert("no such branch"); */
859 Perl_sharedsv_associate(aTHX_ sv, *svp);
860 sv_setsv(sv, *svp);
861 }
862 } else {
863 /* Not in the array */
864 sv_setsv(sv, &PL_sv_undef);
68795e93 865 }
6b85e4fe 866 LEAVE_LOCK;
7473853a 867 return (0);
68795e93
NIS
868}
869
7473853a 870/* Set magic for PERL_MAGIC_tiedelem(p) */
29ecdb6f 871
21312124
NIS
872int
873sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
874{
875 dTHXc;
29ecdb6f 876 SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
6b85e4fe 877 SV **svp;
21312124
NIS
878 /* Theory - SV itself is magically shared - and we have ordered the
879 magic such that by the time we get here it has been stored
880 to its shared counterpart
881 */
6d56dc1c 882 ENTER_LOCK;
29ecdb6f
DM
883 assert(saggregate);
884 if (SvTYPE(saggregate) == SVt_PVAV) {
7473853a
SP
885 assert ( mg->mg_ptr == 0 );
886 SHARED_CONTEXT;
887 svp = av_fetch((AV*) saggregate, mg->mg_len, 1);
888 } else {
889 char *key = mg->mg_ptr;
890 STRLEN len = mg->mg_len;
891 assert ( mg->mg_ptr != 0 );
892 if (mg->mg_len == HEf_SVKEY)
893 key = SvPV((SV *) mg->mg_ptr, len);
894 SHARED_CONTEXT;
895 svp = hv_fetch((HV*) saggregate, key, len, 1);
21312124 896 }
6b85e4fe 897 CALLER_CONTEXT;
29ecdb6f
DM
898 Perl_sharedsv_associate(aTHX_ sv, *svp);
899 sharedsv_scalar_store(aTHX_ sv, *svp);
6b85e4fe 900 LEAVE_LOCK;
7473853a 901 return (0);
21312124 902}
68795e93 903
7473853a 904/* Clear magic for PERL_MAGIC_tiedelem(p) */
29ecdb6f 905
21312124
NIS
906int
907sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
68795e93 908{
21312124 909 dTHXc;
057e91b3 910 MAGIC *shmg;
29ecdb6f 911 SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
6b85e4fe
NIS
912 ENTER_LOCK;
913 sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
057e91b3 914 if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
7473853a 915 sharedsv_scalar_mg_get(aTHX_ sv, shmg);
29ecdb6f 916 if (SvTYPE(saggregate) == SVt_PVAV) {
7473853a
SP
917 SHARED_CONTEXT;
918 av_delete((AV*) saggregate, mg->mg_len, G_DISCARD);
919 } else {
920 char *key = mg->mg_ptr;
921 STRLEN len = mg->mg_len;
922 assert ( mg->mg_ptr != 0 );
923 if (mg->mg_len == HEf_SVKEY)
924 key = SvPV((SV *) mg->mg_ptr, len);
925 SHARED_CONTEXT;
926 hv_delete((HV*) saggregate, key, len, G_DISCARD);
21312124 927 }
6b85e4fe
NIS
928 CALLER_CONTEXT;
929 LEAVE_LOCK;
7473853a 930 return (0);
21312124
NIS
931}
932
29ecdb6f
DM
933/* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new
934 * thread */
935
21312124
NIS
936int
937sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
938{
7473853a 939 SvREFCNT_inc_void(S_sharedsv_from_obj(aTHX_ mg->mg_obj));
29ecdb6f 940 assert(mg->mg_flags & MGf_DUP);
7473853a 941 return (0);
21312124
NIS
942}
943
944MGVTBL sharedsv_elem_vtbl = {
7473853a
SP
945 sharedsv_elem_mg_FETCH, /* get */
946 sharedsv_elem_mg_STORE, /* set */
947 0, /* len */
948 sharedsv_elem_mg_DELETE, /* clear */
949 0, /* free */
950 0, /* copy */
951 sharedsv_elem_mg_dup, /* dup */
952#ifdef MGf_LOCAL
953 0, /* local */
954#endif
21312124
NIS
955};
956
29ecdb6f
DM
957/* ------------ PERL_MAGIC_tied(P) functions -------------- */
958
7473853a 959/* Len magic for PERL_MAGIC_tied(P) */
29ecdb6f 960
21312124
NIS
961U32
962sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
963{
964 dTHXc;
29ecdb6f 965 SV *ssv = (SV *) mg->mg_ptr;
21312124
NIS
966 U32 val;
967 SHARED_EDIT;
29ecdb6f 968 if (SvTYPE(ssv) == SVt_PVAV) {
7473853a
SP
969 val = av_len((AV*) ssv);
970 } else {
971 /* Not actually defined by tie API but ... */
972 val = HvKEYS((HV*) ssv);
21312124
NIS
973 }
974 SHARED_RELEASE;
7473853a 975 return (val);
21312124
NIS
976}
977
7473853a 978/* Clear magic for PERL_MAGIC_tied(P) */
29ecdb6f 979
21312124
NIS
980int
981sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
982{
983 dTHXc;
29ecdb6f 984 SV *ssv = (SV *) mg->mg_ptr;
21312124 985 SHARED_EDIT;
29ecdb6f 986 if (SvTYPE(ssv) == SVt_PVAV) {
7473853a
SP
987 av_clear((AV*) ssv);
988 } else {
989 hv_clear((HV*) ssv);
21312124
NIS
990 }
991 SHARED_RELEASE;
7473853a 992 return (0);
21312124
NIS
993}
994
7473853a 995/* Free magic for PERL_MAGIC_tied(P) */
29ecdb6f 996
21312124
NIS
997int
998sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
999{
29ecdb6f 1000 S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr);
7473853a 1001 return (0);
68795e93
NIS
1002}
1003
1004/*
7473853a 1005 * Copy magic for PERL_MAGIC_tied(P)
21312124
NIS
1006 * This is called when perl is about to access an element of
1007 * the array -
1008 */
1009int
1010sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
7473853a 1011 SV *nsv, const char *name, int namlen)
21312124 1012{
21312124 1013 MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
7473853a
SP
1014 toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
1015 name, namlen);
21312124 1016 nmg->mg_flags |= MGf_DUP;
7473853a 1017 return (1);
21312124
NIS
1018}
1019
29ecdb6f
DM
1020/* Called during cloning of PERL_MAGIC_tied(P) magic in new thread */
1021
21312124
NIS
1022int
1023sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
1024{
7473853a 1025 SvREFCNT_inc_void((SV*)mg->mg_ptr);
29ecdb6f 1026 assert(mg->mg_flags & MGf_DUP);
7473853a 1027 return (0);
21312124
NIS
1028}
1029
1030MGVTBL sharedsv_array_vtbl = {
7473853a
SP
1031 0, /* get */
1032 0, /* set */
1033 sharedsv_array_mg_FETCHSIZE,/* len */
1034 sharedsv_array_mg_CLEAR, /* clear */
1035 sharedsv_array_mg_free, /* free */
1036 sharedsv_array_mg_copy, /* copy */
1037 sharedsv_array_mg_dup, /* dup */
1038#ifdef MGf_LOCAL
1039 0, /* local */
1040#endif
21312124
NIS
1041};
1042
68795e93 1043
ba2940ce 1044/* Recursively unlocks a shared sv. */
68795e93
NIS
1045
1046void
29ecdb6f 1047Perl_sharedsv_unlock(pTHX_ SV *ssv)
68795e93 1048{
29ecdb6f
DM
1049 user_lock *ul = S_get_userlock(aTHX_ ssv, 0);
1050 assert(ul);
1051 recursive_lock_release(aTHX_ &ul->lock);
68795e93
NIS
1052}
1053
68795e93 1054
ba2940ce
JH
1055/* Recursive locks on a sharedsv.
1056 * Locks are dynamically scoped at the level of the first lock.
1057 */
68795e93 1058void
29ecdb6f 1059Perl_sharedsv_lock(pTHX_ SV *ssv)
68795e93 1060{
29ecdb6f 1061 user_lock *ul;
7473853a
SP
1062 if (! ssv)
1063 return;
29ecdb6f
DM
1064 ul = S_get_userlock(aTHX_ ssv, 1);
1065 recursive_lock_acquire(aTHX_ &ul->lock, __FILE__, __LINE__);
68795e93
NIS
1066}
1067
7473853a 1068/* Handles calls from lock() builtin via PL_lockhook */
afe38520 1069
21312124
NIS
1070void
1071Perl_sharedsv_locksv(pTHX_ SV *sv)
1072{
29ecdb6f 1073 SV *ssv;
afe38520 1074
7473853a
SP
1075 if (SvROK(sv))
1076 sv = SvRV(sv);
29ecdb6f 1077 ssv = Perl_sharedsv_find(aTHX_ sv);
7473853a 1078 if (!ssv)
afe38520 1079 croak("lock can only be used on shared values");
29ecdb6f 1080 Perl_sharedsv_lock(aTHX_ ssv);
b050c948
AB
1081}
1082
b050c948 1083
ba2940ce 1084/* Saves a space for keeping SVs wider than an interpreter. */
21312124
NIS
1085
1086void
1087Perl_sharedsv_init(pTHX)
1088{
7473853a
SP
1089 dTHXc;
1090 /* This pair leaves us in shared context ... */
1091 PL_sharedsv_space = perl_alloc();
1092 perl_construct(PL_sharedsv_space);
1093 CALLER_CONTEXT;
1094 recursive_lock_init(aTHX_ &PL_sharedsv_lock);
1095 PL_lockhook = &Perl_sharedsv_locksv;
1096 PL_sharehook = &Perl_sharedsv_share;
b050c948
AB
1097}
1098
73e09c8f
JH
1099#endif /* USE_ITHREADS */
1100
7473853a 1101MODULE = threads::shared PACKAGE = threads::shared::tie
b050c948 1102
21312124 1103PROTOTYPES: DISABLE
b050c948 1104
73e09c8f 1105#ifdef USE_ITHREADS
6b85e4fe 1106
21312124 1107void
29ecdb6f 1108PUSH(SV *obj, ...)
7473853a
SP
1109 CODE:
1110 dTHXc;
1111 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1112 int i;
1113 for (i = 1; i < items; i++) {
1114 SV* tmp = newSVsv(ST(i));
1115 SV *stmp;
1116 ENTER_LOCK;
1117 stmp = S_sharedsv_new_shared(aTHX_ tmp);
1118 sharedsv_scalar_store(aTHX_ tmp, stmp);
1119 SHARED_CONTEXT;
1120 av_push((AV*) sobj, stmp);
1121 SvREFCNT_inc_void(stmp);
1122 SHARED_RELEASE;
1123 SvREFCNT_dec(tmp);
1124 }
1125
b050c948 1126
21312124 1127void
29ecdb6f 1128UNSHIFT(SV *obj, ...)
7473853a
SP
1129 CODE:
1130 dTHXc;
1131 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1132 int i;
1133 ENTER_LOCK;
1134 SHARED_CONTEXT;
1135 av_unshift((AV*)sobj, items - 1);
1136 CALLER_CONTEXT;
1137 for (i = 1; i < items; i++) {
1138 SV *tmp = newSVsv(ST(i));
1139 SV *stmp = S_sharedsv_new_shared(aTHX_ tmp);
1140 sharedsv_scalar_store(aTHX_ tmp, stmp);
1141 SHARED_CONTEXT;
1142 av_store((AV*) sobj, i - 1, stmp);
1143 SvREFCNT_inc_void(stmp);
1144 CALLER_CONTEXT;
1145 SvREFCNT_dec(tmp);
1146 }
1147 LEAVE_LOCK;
1148
b050c948 1149
21312124 1150void
29ecdb6f 1151POP(SV *obj)
7473853a
SP
1152 CODE:
1153 dTHXc;
1154 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1155 SV* ssv;
1156 ENTER_LOCK;
1157 SHARED_CONTEXT;
1158 ssv = av_pop((AV*)sobj);
1159 CALLER_CONTEXT;
1160 ST(0) = sv_newmortal();
1161 Perl_sharedsv_associate(aTHX_ ST(0), ssv);
1162 SvREFCNT_dec(ssv);
1163 LEAVE_LOCK;
1164 /* XSRETURN(1); - implied */
1165
b050c948 1166
21312124 1167void
29ecdb6f 1168SHIFT(SV *obj)
7473853a
SP
1169 CODE:
1170 dTHXc;
1171 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1172 SV* ssv;
1173 ENTER_LOCK;
1174 SHARED_CONTEXT;
1175 ssv = av_shift((AV*)sobj);
1176 CALLER_CONTEXT;
1177 ST(0) = sv_newmortal();
1178 Perl_sharedsv_associate(aTHX_ ST(0), ssv);
1179 SvREFCNT_dec(ssv);
1180 LEAVE_LOCK;
1181 /* XSRETURN(1); - implied */
1182
b050c948 1183
21312124 1184void
29ecdb6f 1185EXTEND(SV *obj, IV count)
7473853a
SP
1186 CODE:
1187 dTHXc;
1188 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1189 SHARED_EDIT;
1190 av_extend((AV*)sobj, count);
1191 SHARED_RELEASE;
1192
b050c948 1193
21312124 1194void
29ecdb6f 1195STORESIZE(SV *obj,IV count)
7473853a
SP
1196 CODE:
1197 dTHXc;
1198 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1199 SHARED_EDIT;
1200 av_fill((AV*) sobj, count);
1201 SHARED_RELEASE;
6b85e4fe
NIS
1202
1203
1204void
29ecdb6f 1205EXISTS(SV *obj, SV *index)
7473853a
SP
1206 CODE:
1207 dTHXc;
1208 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1209 bool exists;
1210 if (SvTYPE(sobj) == SVt_PVAV) {
1211 SHARED_EDIT;
1212 exists = av_exists((AV*) sobj, SvIV(index));
1213 } else {
1214 STRLEN len;
1215 char *key = SvPV(index,len);
1216 SHARED_EDIT;
1217 exists = hv_exists((HV*) sobj, key, len);
1218 }
1219 SHARED_RELEASE;
1220 ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
1221 /* XSRETURN(1); - implied */
b050c948
AB
1222
1223
1224void
29ecdb6f 1225FIRSTKEY(SV *obj)
7473853a
SP
1226 CODE:
1227 dTHXc;
1228 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1229 char* key = NULL;
1230 I32 len = 0;
1231 HE* entry;
1232 ENTER_LOCK;
1233 SHARED_CONTEXT;
1234 hv_iterinit((HV*) sobj);
1235 entry = hv_iternext((HV*) sobj);
1236 if (entry) {
1237 key = hv_iterkey(entry,&len);
1238 CALLER_CONTEXT;
1239 ST(0) = sv_2mortal(newSVpv(key, len));
1240 } else {
1241 CALLER_CONTEXT;
1242 ST(0) = &PL_sv_undef;
1243 }
1244 LEAVE_LOCK;
1245 /* XSRETURN(1); - implied */
1246
b050c948 1247
866fba46 1248void
29ecdb6f 1249NEXTKEY(SV *obj, SV *oldkey)
7473853a
SP
1250 CODE:
1251 dTHXc;
1252 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1253 char* key = NULL;
1254 I32 len = 0;
1255 HE* entry;
1256 ENTER_LOCK;
1257 SHARED_CONTEXT;
1258 entry = hv_iternext((HV*) sobj);
1259 if (entry) {
1260 key = hv_iterkey(entry,&len);
1261 CALLER_CONTEXT;
1262 ST(0) = sv_2mortal(newSVpv(key, len));
1263 } else {
1264 CALLER_CONTEXT;
1265 ST(0) = &PL_sv_undef;
1266 }
1267 LEAVE_LOCK;
1268 /* XSRETURN(1); - implied */
1269
1270
1271MODULE = threads::shared PACKAGE = threads::shared
21312124
NIS
1272
1273PROTOTYPES: ENABLE
866fba46 1274
68795e93 1275void
9c4972d9 1276_id(SV *ref)
7473853a
SP
1277 PROTOTYPE: \[$@%]
1278 PREINIT:
1279 SV *ssv;
1280 CODE:
1281 ref = SvRV(ref);
1282 if (SvROK(ref))
1283 ref = SvRV(ref);
1284 ssv = Perl_sharedsv_find(aTHX_ ref);
1285 if (! ssv)
1286 XSRETURN_UNDEF;
1287 ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv)));
1288 /* XSRETURN(1); - implied */
9c4972d9
NIS
1289
1290
1291void
6b85e4fe 1292_refcnt(SV *ref)
7473853a
SP
1293 PROTOTYPE: \[$@%]
1294 PREINIT:
1295 SV *ssv;
1296 CODE:
1297 ref = SvRV(ref);
1298 if (SvROK(ref))
1299 ref = SvRV(ref);
1300 ssv = Perl_sharedsv_find(aTHX_ ref);
1301 if (! ssv) {
1302 Perl_warn(aTHX_ "%" SVf " is not shared", ST(0));
1303 XSRETURN_UNDEF;
1304 }
1305 ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv)));
1306 /* XSRETURN(1); - implied */
1307
1308
1309void
a446a88f 1310share(SV *ref)
7473853a
SP
1311 PROTOTYPE: \[$@%]
1312 CODE:
1313 if (! SvROK(ref))
56fcff86 1314 Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
7473853a
SP
1315 ref = SvRV(ref);
1316 if (SvROK(ref))
1317 ref = SvRV(ref);
1318 Perl_sharedsv_share(aTHX_ ref);
1319 ST(0) = sv_2mortal(newRV_inc(ref));
1320 /* XSRETURN(1); - implied */
a446a88f 1321
6f942b98
AB
1322
1323void
7473853a
SP
1324cond_wait(SV *ref_cond, SV *ref_lock = 0)
1325 PROTOTYPE: \[$@%];\[$@%]
1326 PREINIT:
1327 SV *ssv;
1328 perl_cond* user_condition;
1329 int locks;
1330 user_lock *ul;
1331 CODE:
1332 if (!SvROK(ref_cond))
56fcff86 1333 Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
7473853a
SP
1334 ref_cond = SvRV(ref_cond);
1335 if (SvROK(ref_cond))
1336 ref_cond = SvRV(ref_cond);
1337 ssv = Perl_sharedsv_find(aTHX_ ref_cond);
1338 if (! ssv)
1339 Perl_croak(aTHX_ "cond_wait can only be used on shared values");
1340 ul = S_get_userlock(aTHX_ ssv, 1);
1341
1342 user_condition = &ul->user_cond;
1343 if (ref_lock && (ref_cond != ref_lock)) {
1344 if (!SvROK(ref_lock))
1345 Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref");
1346 ref_lock = SvRV(ref_lock);
1347 if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1348 ssv = Perl_sharedsv_find(aTHX_ ref_lock);
1349 if (! ssv)
1350 Perl_croak(aTHX_ "cond_wait lock must be a shared value");
1351 ul = S_get_userlock(aTHX_ ssv, 1);
1352 }
1353 if (ul->lock.owner != aTHX)
1354 croak("You need a lock before you can cond_wait");
ba2940ce 1355
7473853a
SP
1356 /* Stealing the members of the lock object worries me - NI-S */
1357 MUTEX_LOCK(&ul->lock.mutex);
1358 ul->lock.owner = NULL;
1359 locks = ul->lock.locks;
1360 ul->lock.locks = 0;
1361
ba2940ce
JH
1362 /* Since we are releasing the lock here, we need to tell other
1363 * people that it is ok to go ahead and use it */
7473853a
SP
1364 COND_SIGNAL(&ul->lock.cond);
1365 COND_WAIT(user_condition, &ul->lock.mutex);
ba2940ce 1366 while (ul->lock.owner != NULL) {
7473853a
SP
1367 /* OK -- must reacquire the lock */
1368 COND_WAIT(&ul->lock.cond, &ul->lock.mutex);
1369 }
1370 ul->lock.owner = aTHX;
1371 ul->lock.locks = locks;
1372 MUTEX_UNLOCK(&ul->lock.mutex);
1373
a0e036c1
MP
1374
1375int
7473853a
SP
1376cond_timedwait(SV *ref_cond, double abs, SV *ref_lock = 0)
1377 PROTOTYPE: \[$@%]$;\[$@%]
1378 PREINIT:
1379 SV *ssv;
1380 perl_cond* user_condition;
1381 int locks;
1382 user_lock *ul;
1383 CODE:
1384 if (! SvROK(ref_cond))
1385 Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref");
1386 ref_cond = SvRV(ref_cond);
1387 if (SvROK(ref_cond))
1388 ref_cond = SvRV(ref_cond);
1389 ssv = Perl_sharedsv_find(aTHX_ ref_cond);
1390 if (! ssv)
1391 Perl_croak(aTHX_ "cond_timedwait can only be used on shared values");
1392 ul = S_get_userlock(aTHX_ ssv, 1);
1393
1394 user_condition = &ul->user_cond;
1395 if (ref_lock && (ref_cond != ref_lock)) {
1396 if (! SvROK(ref_lock))
1397 Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref");
1398 ref_lock = SvRV(ref_lock);
1399 if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1400 ssv = Perl_sharedsv_find(aTHX_ ref_lock);
1401 if (! ssv)
1402 Perl_croak(aTHX_ "cond_timedwait lock must be a shared value");
1403 ul = S_get_userlock(aTHX_ ssv, 1);
1404 }
1405 if (ul->lock.owner != aTHX)
1406 Perl_croak(aTHX_ "You need a lock before you can cond_wait");
1407
1408 MUTEX_LOCK(&ul->lock.mutex);
1409 ul->lock.owner = NULL;
1410 locks = ul->lock.locks;
1411 ul->lock.locks = 0;
ba2940ce
JH
1412 /* Since we are releasing the lock here, we need to tell other
1413 * people that it is ok to go ahead and use it */
7473853a
SP
1414 COND_SIGNAL(&ul->lock.cond);
1415 RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs);
1416 while (ul->lock.owner != NULL) {
1417 /* OK -- must reacquire the lock... */
1418 COND_WAIT(&ul->lock.cond, &ul->lock.mutex);
1419 }
1420 ul->lock.owner = aTHX;
1421 ul->lock.locks = locks;
1422 MUTEX_UNLOCK(&ul->lock.mutex);
1423
1424 if (RETVAL == 0)
a0e036c1 1425 XSRETURN_UNDEF;
7473853a
SP
1426 OUTPUT:
1427 RETVAL
a0e036c1 1428
29ecdb6f 1429
7473853a
SP
1430void
1431cond_signal(SV *ref)
1432 PROTOTYPE: \[$@%]
1433 PREINIT:
1434 SV *ssv;
1435 user_lock *ul;
1436 CODE:
1437 if (! SvROK(ref))
56fcff86 1438 Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
7473853a
SP
1439 ref = SvRV(ref);
1440 if (SvROK(ref))
1441 ref = SvRV(ref);
1442 ssv = Perl_sharedsv_find(aTHX_ ref);
1443 if (! ssv)
1444 Perl_croak(aTHX_ "cond_signal can only be used on shared values");
1445 ul = S_get_userlock(aTHX_ ssv, 1);
1446 if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) {
1447 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1448 "cond_signal() called on unlocked variable");
1449 }
1450 COND_SIGNAL(&ul->user_cond);
6f942b98 1451
29ecdb6f 1452
7473853a
SP
1453void
1454cond_broadcast(SV *ref)
1455 PROTOTYPE: \[$@%]
1456 PREINIT:
1457 SV *ssv;
1458 user_lock *ul;
1459 CODE:
1460 if (! SvROK(ref))
56fcff86 1461 Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
7473853a
SP
1462 ref = SvRV(ref);
1463 if (SvROK(ref))
1464 ref = SvRV(ref);
1465 ssv = Perl_sharedsv_find(aTHX_ ref);
1466 if (! ssv)
1467 Perl_croak(aTHX_ "cond_broadcast can only be used on shared values");
1468 ul = S_get_userlock(aTHX_ ssv, 1);
1469 if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) {
1470 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1471 "cond_broadcast() called on unlocked variable");
1472 }
1473 COND_BROADCAST(&ul->user_cond);
1474
1475
1476void
5c360ac5 1477bless(SV* ref, ...);
7473853a
SP
1478 PROTOTYPE: $;$
1479 PREINIT:
1480 HV* stash;
1481 SV *ssv;
1482 CODE:
1483 if (items == 1) {
1484 stash = CopSTASH(PL_curcop);
1485 } else {
1486 SV* classname = ST(1);
1487 STRLEN len;
1488 char *ptr;
1489
1490 if (classname &&
1491 ! SvGMAGICAL(classname) &&
1492 ! SvAMAGIC(classname) &&
1493 SvROK(classname))
1494 {
1495 Perl_croak(aTHX_ "Attempt to bless into a reference");
1496 }
1497 ptr = SvPV(classname, len);
1498 if (ckWARN(WARN_MISC) && len == 0) {
1499 Perl_warner(aTHX_ packWARN(WARN_MISC),
1500 "Explicit blessing to '' (assuming package main)");
1501 }
1502 stash = gv_stashpvn(ptr, len, TRUE);
1503 }
1504 SvREFCNT_inc_void(ref);
1505 (void)sv_bless(ref, stash);
1506 ST(0) = sv_2mortal(ref);
1507 ssv = Perl_sharedsv_find(aTHX_ ref);
1508 if (ssv) {
1509 dTHXc;
1510 ENTER_LOCK;
1511 SHARED_CONTEXT;
1512 {
1513 SV* fake_stash = newSVpv(HvNAME_get(stash), 0);
1514 (void)sv_bless(ssv, (HV*)fake_stash);
1515 }
1516 CALLER_CONTEXT;
1517 LEAVE_LOCK;
1518 }
1519 /* XSRETURN(1); - implied */
5c360ac5 1520
73e09c8f
JH
1521#endif /* USE_ITHREADS */
1522
68795e93
NIS
1523BOOT:
1524{
73e09c8f 1525#ifdef USE_ITHREADS
68795e93 1526 Perl_sharedsv_init(aTHX);
73e09c8f 1527#endif /* USE_ITHREADS */
68795e93 1528}