This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Changes for threads::shared to all building with g++.
[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);
208 if (lock->owner != aTHX) {
7473853a
SP
209 MUTEX_UNLOCK(&lock->mutex);
210 } else if (--lock->locks == 0) {
211 lock->owner = NULL;
212 COND_SIGNAL(&lock->cond);
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
12b31bed
SP
321extern MGVTBL sharedsv_scalar_vtbl; /* Scalars have this vtable */
322extern MGVTBL sharedsv_array_vtbl; /* Hashes and arrays have this - like 'tie' */
323extern MGVTBL sharedsv_elem_vtbl; /* Elements of hashes and arrays have this
324 _AS WELL AS_ the scalar magic:
29ecdb6f 325 The sharedsv_elem_vtbl associates the element with the array/hash and
21312124
NIS
326 the sharedsv_scalar_vtbl associates it with the value
327 */
328
6b85e4fe 329
7473853a 330/* Get shared aggregate SV pointed to by threads::shared::tie magic object */
29ecdb6f
DM
331
332STATIC SV *
333S_sharedsv_from_obj(pTHX_ SV *sv)
6b85e4fe 334{
7473853a 335 return ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL);
29ecdb6f
DM
336}
337
338
339/* Return the user_lock structure (if any) associated with a shared SV.
7473853a
SP
340 * If create is true, create one if it doesn't exist
341 */
29ecdb6f
DM
342STATIC user_lock *
343S_get_userlock(pTHX_ SV* ssv, bool create)
344{
345 MAGIC *mg;
346 user_lock *ul = NULL;
347
348 assert(ssv);
7473853a 349 /* XXX Redesign the storage of user locks so we don't need a global
29ecdb6f
DM
350 * lock to access them ???? DAPM */
351 ENTER_LOCK;
352 mg = mg_find(ssv, PERL_MAGIC_ext);
7473853a
SP
353 if (mg) {
354 ul = (user_lock*)(mg->mg_ptr);
355 } else if (create) {
356 dTHXc;
357 SHARED_CONTEXT;
358 ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock));
359 Zero(ul, 1, user_lock);
360 /* Attach to shared SV using ext magic */
361 sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl,
362 (char *)ul, 0);
363 recursive_lock_init(aTHX_ &ul->lock);
364 COND_INIT(&ul->user_cond);
365 CALLER_CONTEXT;
29ecdb6f
DM
366 }
367 LEAVE_LOCK;
7473853a 368 return (ul);
6b85e4fe
NIS
369}
370
29ecdb6f 371
21312124
NIS
372=for apidoc sharedsv_find
373
6b85e4fe 374Given a private side SV tries to find if the SV has a shared backend,
21312124
NIS
375by looking for the magic.
376
377=cut
378
29ecdb6f 379SV *
21312124
NIS
380Perl_sharedsv_find(pTHX_ SV *sv)
381{
382 MAGIC *mg;
a446a88f 383 if (SvTYPE(sv) >= SVt_PVMG) {
7473853a
SP
384 switch(SvTYPE(sv)) {
385 case SVt_PVAV:
386 case SVt_PVHV:
387 if ((mg = mg_find(sv, PERL_MAGIC_tied))
388 && mg->mg_virtual == &sharedsv_array_vtbl) {
389 return ((SV *)mg->mg_ptr);
390 }
391 break;
392 default:
393 /* This should work for elements as well as they
394 * have scalar magic as well as their element magic
395 */
396 if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar))
397 && mg->mg_virtual == &sharedsv_scalar_vtbl) {
398 return ((SV *)mg->mg_ptr);
399 }
400 break;
401 }
21312124 402 }
6b85e4fe
NIS
403 /* Just for tidyness of API also handle tie objects */
404 if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) {
7473853a 405 return (S_sharedsv_from_obj(aTHX_ sv));
6b85e4fe 406 }
7473853a 407 return (NULL);
21312124 408}
68795e93 409
68795e93 410
7473853a
SP
411/* Associate a private SV with a shared SV by pointing the appropriate
412 * magics at it.
413 * Assumes lock is held.
414 */
29ecdb6f
DM
415void
416Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv)
21312124 417{
21312124 418 dTHXc;
a446a88f 419 MAGIC *mg = 0;
a446a88f 420
29ecdb6f 421 /* If we are asked for any private ops we need a thread */
a446a88f
NIS
422 assert ( aTHX != PL_sharedsv_space );
423
424 /* To avoid need for recursive locks require caller to hold lock */
6d56dc1c 425 assert ( PL_sharedsv_lock.owner == aTHX );
6b85e4fe 426
29ecdb6f
DM
427 switch(SvTYPE(sv)) {
428 case SVt_PVAV:
429 case SVt_PVHV:
7473853a
SP
430 if (!(mg = mg_find(sv, PERL_MAGIC_tied))
431 || mg->mg_virtual != &sharedsv_array_vtbl
432 || (SV*) mg->mg_ptr != ssv)
433 {
434 SV *obj = newSV(0);
435 sv_setref_iv(obj, "threads::shared::tie", PTR2IV(ssv));
436 if (mg) {
437 sv_unmagic(sv, PERL_MAGIC_tied);
438 }
439 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
440 (char *)ssv, 0);
441 mg->mg_flags |= (MGf_COPY|MGf_DUP);
442 SvREFCNT_inc_void(ssv);
443 SvREFCNT_dec(obj);
444 }
445 break;
68795e93 446
29ecdb6f 447 default:
7473853a
SP
448 if ((SvTYPE(sv) < SVt_PVMG)
449 || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar))
450 || mg->mg_virtual != &sharedsv_scalar_vtbl
451 || (SV*) mg->mg_ptr != ssv)
452 {
453 if (mg) {
454 sv_unmagic(sv, PERL_MAGIC_shared_scalar);
455 }
456 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
457 &sharedsv_scalar_vtbl, (char *)ssv, 0);
458 mg->mg_flags |= (MGf_DUP
459#ifdef MGf_LOCAL
460 |MGf_LOCAL
461#endif
462 );
463 SvREFCNT_inc_void(ssv);
464 }
465 break;
21312124 466 }
7473853a 467
29ecdb6f
DM
468 assert ( Perl_sharedsv_find(aTHX_ sv) == ssv );
469}
6b85e4fe 470
6b85e4fe 471
29ecdb6f 472/* Given a private SV, create and return an associated shared SV.
7473853a
SP
473 * Assumes lock is held.
474 */
29ecdb6f
DM
475STATIC SV *
476S_sharedsv_new_shared(pTHX_ SV *sv)
477{
478 dTHXc;
479 SV *ssv;
6b85e4fe 480
29ecdb6f
DM
481 assert(PL_sharedsv_lock.owner == aTHX);
482 assert(aTHX != PL_sharedsv_space);
68795e93 483
29ecdb6f
DM
484 SHARED_CONTEXT;
485 ssv = newSV(0);
7473853a 486 SvREFCNT(ssv) = 0; /* Will be upped to 1 by Perl_sharedsv_associate */
29ecdb6f
DM
487 sv_upgrade(ssv, SvTYPE(sv));
488 CALLER_CONTEXT;
489 Perl_sharedsv_associate(aTHX_ sv, ssv);
7473853a 490 return (ssv);
29ecdb6f 491}
21312124 492
21312124 493
29ecdb6f 494/* Given a shared SV, create and return an associated private SV.
7473853a
SP
495 * Assumes lock is held.
496 */
29ecdb6f
DM
497STATIC SV *
498S_sharedsv_new_private(pTHX_ SV *ssv)
499{
500 SV *sv;
501
502 assert(PL_sharedsv_lock.owner == aTHX);
503 assert(aTHX != PL_sharedsv_space);
504
505 sv = newSV(0);
506 sv_upgrade(sv, SvTYPE(ssv));
507 Perl_sharedsv_associate(aTHX_ sv, ssv);
7473853a 508 return (sv);
21312124 509}
68795e93 510
29ecdb6f 511
7473853a 512/* A threadsafe version of SvREFCNT_dec(ssv) */
29ecdb6f
DM
513
514STATIC void
515S_sharedsv_dec(pTHX_ SV* ssv)
68795e93 516{
7473853a
SP
517 if (! ssv)
518 return;
29ecdb6f
DM
519 ENTER_LOCK;
520 if (SvREFCNT(ssv) > 1) {
7473853a
SP
521 /* No side effects, so can do it lightweight */
522 SvREFCNT_dec(ssv);
523 } else {
524 dTHXc;
525 SHARED_CONTEXT;
526 SvREFCNT_dec(ssv);
527 CALLER_CONTEXT;
21312124 528 }
29ecdb6f 529 LEAVE_LOCK;
68795e93
NIS
530}
531
7473853a
SP
532
533/* Implements Perl-level share() and :shared */
29ecdb6f 534
21312124
NIS
535void
536Perl_sharedsv_share(pTHX_ SV *sv)
537{
538 switch(SvTYPE(sv)) {
539 case SVt_PVGV:
7473853a
SP
540 Perl_croak(aTHX_ "Cannot share globs yet");
541 break;
21312124
NIS
542
543 case SVt_PVCV:
7473853a
SP
544 Perl_croak(aTHX_ "Cannot share subs yet");
545 break;
85e0a142 546
21312124 547 default:
7473853a
SP
548 ENTER_LOCK;
549 (void) S_sharedsv_new_shared(aTHX_ sv);
550 LEAVE_LOCK;
551 SvSETMAGIC(sv);
552 break;
21312124
NIS
553 }
554}
68795e93 555
7473853a 556
a0e036c1 557#if defined(WIN32) || defined(OS2)
7473853a 558# define ABS2RELMILLI(abs) \
a0e036c1 559 do { \
2666606c 560 abs -= (double)time(NULL); \
a0e036c1
MP
561 if (abs > 0) { abs *= 1000; } \
562 else { abs = 0; } \
563 } while (0)
564#endif /* WIN32 || OS2 */
565
7473853a 566/* Do OS-specific condition timed wait */
29ecdb6f 567
a0e036c1
MP
568bool
569Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs)
570{
571#if defined(NETWARE) || defined(FAKE_THREADS) || defined(I_MACH_CTHREADS)
572 Perl_croak_nocontext("cond_timedwait not supported on this platform");
573#else
574# ifdef WIN32
575 int got_it = 0;
576
577 ABS2RELMILLI(abs);
578
579 cond->waiters++;
580 MUTEX_UNLOCK(mut);
581 /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */
028f8eaa 582 switch (WaitForSingleObject(cond->sem, (DWORD)abs)) {
a0e036c1
MP
583 case WAIT_OBJECT_0: got_it = 1; break;
584 case WAIT_TIMEOUT: break;
585 default:
586 /* WAIT_FAILED? WAIT_ABANDONED? others? */
587 Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError());
588 break;
589 }
590 MUTEX_LOCK(mut);
2666606c 591 cond->waiters--;
7473853a 592 return (got_it);
a0e036c1
MP
593# else
594# ifdef OS2
595 int rc, got_it = 0;
596 STRLEN n_a;
597
598 ABS2RELMILLI(abs);
599
600 if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET))
601 Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset");
602 MUTEX_UNLOCK(mut);
603 if (CheckOSError(DosWaitEventSem(*cond,abs))
604 && (rc != ERROR_INTERRUPT))
605 croak_with_os2error("panic: cond_timedwait");
606 if (rc == ERROR_INTERRUPT) errno = EINTR;
607 MUTEX_LOCK(mut);
7473853a
SP
608 return (got_it);
609# else /* Hope you're I_PTHREAD! */
a0e036c1
MP
610 struct timespec ts;
611 int got_it = 0;
612
613 ts.tv_sec = (long)abs;
614 abs -= (NV)ts.tv_sec;
615 ts.tv_nsec = (long)(abs * 1000000000.0);
616
617 switch (pthread_cond_timedwait(cond, mut, &ts)) {
618 case 0: got_it = 1; break;
619 case ETIMEDOUT: break;
cf0d1c66
JH
620#ifdef OEMVS
621 case -1:
7473853a
SP
622 if (errno == ETIMEDOUT || errno == EAGAIN)
623 break;
cf0d1c66 624#endif
a0e036c1
MP
625 default:
626 Perl_croak_nocontext("panic: cond_timedwait");
627 break;
628 }
7473853a 629 return (got_it);
a0e036c1
MP
630# endif /* OS2 */
631# endif /* WIN32 */
632#endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */
633}
634
dad67c22 635
7473853a 636/* Given a shared RV, copy it's value to a private RV, also copying the
dad67c22
DM
637 * object status of the referent.
638 * If the private side is already an appropriate RV->SV combination, keep
639 * it if possible.
640 */
dad67c22
DM
641STATIC void
642S_get_RV(pTHX_ SV *sv, SV *ssv) {
643 SV *sobj = SvRV(ssv);
644 SV *obj;
7473853a
SP
645 if (! (SvROK(sv) &&
646 ((obj = SvRV(sv))) &&
647 (Perl_sharedsv_find(aTHX_ obj) == sobj) &&
648 (SvTYPE(obj) == SvTYPE(sobj))))
dad67c22 649 {
7473853a
SP
650 /* Can't reuse obj */
651 if (SvROK(sv)) {
652 SvREFCNT_dec(SvRV(sv));
653 } else {
654 assert(SvTYPE(sv) >= SVt_RV);
655 sv_setsv_nomg(sv, &PL_sv_undef);
656 SvROK_on(sv);
657 }
658 obj = S_sharedsv_new_private(aTHX_ SvRV(ssv));
659 SvRV_set(sv, obj);
dad67c22
DM
660 }
661
662 if (SvOBJECT(obj)) {
7473853a
SP
663 /* Remove any old blessing */
664 SvREFCNT_dec(SvSTASH(obj));
665 SvOBJECT_off(obj);
dad67c22
DM
666 }
667 if (SvOBJECT(sobj)) {
7473853a
SP
668 /* Add any new old blessing */
669 STRLEN len;
670 char* stash_ptr = SvPV((SV*) SvSTASH(sobj), len);
671 HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
672 SvOBJECT_on(obj);
673 SvSTASH_set(obj, (HV*)SvREFCNT_inc(stash));
dad67c22
DM
674 }
675}
676
677
29ecdb6f
DM
678/* ------------ PERL_MAGIC_shared_scalar(n) functions -------------- */
679
7473853a 680/* Get magic for PERL_MAGIC_shared_scalar(n) */
68795e93 681
21312124
NIS
682int
683sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
68795e93 684{
29ecdb6f
DM
685 SV *ssv = (SV *) mg->mg_ptr;
686 assert(ssv);
21312124 687
6d56dc1c 688 ENTER_LOCK;
29ecdb6f 689 if (SvROK(ssv)) {
7473853a
SP
690 S_get_RV(aTHX_ sv, ssv);
691 } else {
692 sv_setsv_nomg(sv, ssv);
21312124 693 }
6d56dc1c 694 LEAVE_LOCK;
7473853a 695 return (0);
21312124
NIS
696}
697
7473853a
SP
698/* Copy the contents of a private SV to a shared SV.
699 * Used by various mg_set()-type functions.
700 * Assumes lock is held.
701 */
6b85e4fe 702void
29ecdb6f 703sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv)
21312124
NIS
704{
705 dTHXc;
21312124 706 bool allowed = TRUE;
29ecdb6f
DM
707
708 assert(PL_sharedsv_lock.owner == aTHX);
21312124 709 if (SvROK(sv)) {
7473853a
SP
710 SV *obj = SvRV(sv);
711 SV *sobj = Perl_sharedsv_find(aTHX_ obj);
712 if (sobj) {
713 SHARED_CONTEXT;
714 SvUPGRADE(ssv, SVt_RV);
715 sv_setsv_nomg(ssv, &PL_sv_undef);
716
717 SvRV_set(ssv, SvREFCNT_inc(sobj));
718 SvROK_on(ssv);
719 if (SvOBJECT(sobj)) {
720 /* Remove any old blessing */
721 SvREFCNT_dec(SvSTASH(sobj));
722 SvOBJECT_off(sobj);
723 }
724 if (SvOBJECT(obj)) {
725 SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(obj)),0);
726 SvOBJECT_on(sobj);
727 SvSTASH_set(sobj, (HV*)fake_stash);
728 }
729 CALLER_CONTEXT;
730 } else {
731 allowed = FALSE;
732 }
733 } else {
5c360ac5 734 SvTEMP_off(sv);
7473853a
SP
735 SHARED_CONTEXT;
736 sv_setsv_nomg(ssv, sv);
737 if (SvOBJECT(ssv)) {
738 /* Remove any old blessing */
739 SvREFCNT_dec(SvSTASH(ssv));
740 SvOBJECT_off(ssv);
741 }
742 if (SvOBJECT(sv)) {
743 SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0);
744 SvOBJECT_on(ssv);
745 SvSTASH_set(ssv, (HV*)fake_stash);
746 }
747 CALLER_CONTEXT;
21312124 748 }
21312124 749 if (!allowed) {
7473853a 750 Perl_croak(aTHX_ "Invalid value for shared scalar");
21312124 751 }
6b85e4fe
NIS
752}
753
7473853a 754/* Set magic for PERL_MAGIC_shared_scalar(n) */
29ecdb6f 755
6b85e4fe
NIS
756int
757sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
758{
29ecdb6f
DM
759 SV *ssv = (SV*)(mg->mg_ptr);
760 assert(ssv);
6b85e4fe 761 ENTER_LOCK;
29ecdb6f 762 if (SvTYPE(ssv) < SvTYPE(sv)) {
7473853a
SP
763 dTHXc;
764 SHARED_CONTEXT;
765 sv_upgrade(ssv, SvTYPE(sv));
766 CALLER_CONTEXT;
29ecdb6f
DM
767 }
768 sharedsv_scalar_store(aTHX_ sv, ssv);
6b85e4fe 769 LEAVE_LOCK;
7473853a 770 return (0);
68795e93
NIS
771}
772
7473853a 773/* Free magic for PERL_MAGIC_shared_scalar(n) */
a446a88f
NIS
774
775int
29ecdb6f 776sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
a446a88f 777{
29ecdb6f 778 S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr);
7473853a 779 return (0);
21312124 780}
68795e93
NIS
781
782/*
29ecdb6f 783 * Called during cloning of PERL_MAGIC_shared_scalar(n) magic in new thread
21312124
NIS
784 */
785int
786sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
787{
7473853a
SP
788 SvREFCNT_inc_void(mg->mg_ptr);
789 return (0);
21312124 790}
68795e93 791
7473853a 792#ifdef MGf_LOCAL
a5063e7c
DM
793/*
794 * Called during local $shared
795 */
796int
797sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg)
798{
799 MAGIC *nmg;
29ecdb6f
DM
800 SV *ssv = (SV *) mg->mg_ptr;
801 if (ssv) {
7473853a
SP
802 ENTER_LOCK;
803 SvREFCNT_inc_void(ssv);
804 LEAVE_LOCK;
a5063e7c
DM
805 }
806 nmg = sv_magicext(nsv, mg->mg_obj, mg->mg_type, mg->mg_virtual,
7473853a 807 mg->mg_ptr, mg->mg_len);
a5063e7c
DM
808 nmg->mg_flags = mg->mg_flags;
809 nmg->mg_private = mg->mg_private;
810
7473853a 811 return (0);
a5063e7c 812}
7473853a 813#endif
a5063e7c 814
21312124 815MGVTBL sharedsv_scalar_vtbl = {
7473853a
SP
816 sharedsv_scalar_mg_get, /* get */
817 sharedsv_scalar_mg_set, /* set */
818 0, /* len */
819 0, /* clear */
820 sharedsv_scalar_mg_free, /* free */
821 0, /* copy */
822 sharedsv_scalar_mg_dup, /* dup */
823#ifdef MGf_LOCAL
824 sharedsv_scalar_mg_local, /* local */
825#endif
21312124 826};
68795e93 827
29ecdb6f
DM
828/* ------------ PERL_MAGIC_tiedelem(p) functions -------------- */
829
7473853a 830/* Get magic for PERL_MAGIC_tiedelem(p) */
29ecdb6f 831
21312124
NIS
832int
833sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
68795e93 834{
21312124 835 dTHXc;
29ecdb6f 836 SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
21312124
NIS
837 SV** svp;
838
6b85e4fe 839 ENTER_LOCK;
29ecdb6f 840 if (SvTYPE(saggregate) == SVt_PVAV) {
7473853a
SP
841 assert ( mg->mg_ptr == 0 );
842 SHARED_CONTEXT;
843 svp = av_fetch((AV*) saggregate, mg->mg_len, 0);
844 } else {
845 char *key = mg->mg_ptr;
846 STRLEN len = mg->mg_len;
847 assert ( mg->mg_ptr != 0 );
848 if (mg->mg_len == HEf_SVKEY) {
849 key = SvPV((SV *) mg->mg_ptr, len);
850 }
851 SHARED_CONTEXT;
852 svp = hv_fetch((HV*) saggregate, key, len, 0);
21312124 853 }
6b85e4fe 854 CALLER_CONTEXT;
21312124 855 if (svp) {
7473853a
SP
856 /* Exists in the array */
857 if (SvROK(*svp)) {
858 S_get_RV(aTHX_ sv, *svp);
859 } else {
860 /* XXX Can this branch ever happen? DAPM */
861 /* XXX assert("no such branch"); */
862 Perl_sharedsv_associate(aTHX_ sv, *svp);
863 sv_setsv(sv, *svp);
864 }
865 } else {
866 /* Not in the array */
867 sv_setsv(sv, &PL_sv_undef);
68795e93 868 }
6b85e4fe 869 LEAVE_LOCK;
7473853a 870 return (0);
68795e93
NIS
871}
872
7473853a 873/* Set magic for PERL_MAGIC_tiedelem(p) */
29ecdb6f 874
21312124
NIS
875int
876sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
877{
878 dTHXc;
29ecdb6f 879 SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
6b85e4fe 880 SV **svp;
21312124
NIS
881 /* Theory - SV itself is magically shared - and we have ordered the
882 magic such that by the time we get here it has been stored
883 to its shared counterpart
884 */
6d56dc1c 885 ENTER_LOCK;
29ecdb6f
DM
886 assert(saggregate);
887 if (SvTYPE(saggregate) == SVt_PVAV) {
7473853a
SP
888 assert ( mg->mg_ptr == 0 );
889 SHARED_CONTEXT;
890 svp = av_fetch((AV*) saggregate, mg->mg_len, 1);
891 } else {
892 char *key = mg->mg_ptr;
893 STRLEN len = mg->mg_len;
894 assert ( mg->mg_ptr != 0 );
895 if (mg->mg_len == HEf_SVKEY)
896 key = SvPV((SV *) mg->mg_ptr, len);
897 SHARED_CONTEXT;
898 svp = hv_fetch((HV*) saggregate, key, len, 1);
21312124 899 }
6b85e4fe 900 CALLER_CONTEXT;
29ecdb6f
DM
901 Perl_sharedsv_associate(aTHX_ sv, *svp);
902 sharedsv_scalar_store(aTHX_ sv, *svp);
6b85e4fe 903 LEAVE_LOCK;
7473853a 904 return (0);
21312124 905}
68795e93 906
7473853a 907/* Clear magic for PERL_MAGIC_tiedelem(p) */
29ecdb6f 908
21312124
NIS
909int
910sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
68795e93 911{
21312124 912 dTHXc;
057e91b3 913 MAGIC *shmg;
29ecdb6f 914 SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
6b85e4fe
NIS
915 ENTER_LOCK;
916 sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
057e91b3 917 if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
7473853a 918 sharedsv_scalar_mg_get(aTHX_ sv, shmg);
29ecdb6f 919 if (SvTYPE(saggregate) == SVt_PVAV) {
7473853a
SP
920 SHARED_CONTEXT;
921 av_delete((AV*) saggregate, mg->mg_len, G_DISCARD);
922 } else {
923 char *key = mg->mg_ptr;
924 STRLEN len = mg->mg_len;
925 assert ( mg->mg_ptr != 0 );
926 if (mg->mg_len == HEf_SVKEY)
927 key = SvPV((SV *) mg->mg_ptr, len);
928 SHARED_CONTEXT;
929 hv_delete((HV*) saggregate, key, len, G_DISCARD);
21312124 930 }
6b85e4fe
NIS
931 CALLER_CONTEXT;
932 LEAVE_LOCK;
7473853a 933 return (0);
21312124
NIS
934}
935
29ecdb6f
DM
936/* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new
937 * thread */
938
21312124
NIS
939int
940sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
941{
7473853a 942 SvREFCNT_inc_void(S_sharedsv_from_obj(aTHX_ mg->mg_obj));
29ecdb6f 943 assert(mg->mg_flags & MGf_DUP);
7473853a 944 return (0);
21312124
NIS
945}
946
947MGVTBL sharedsv_elem_vtbl = {
7473853a
SP
948 sharedsv_elem_mg_FETCH, /* get */
949 sharedsv_elem_mg_STORE, /* set */
950 0, /* len */
951 sharedsv_elem_mg_DELETE, /* clear */
952 0, /* free */
953 0, /* copy */
954 sharedsv_elem_mg_dup, /* dup */
955#ifdef MGf_LOCAL
956 0, /* local */
957#endif
21312124
NIS
958};
959
29ecdb6f
DM
960/* ------------ PERL_MAGIC_tied(P) functions -------------- */
961
7473853a 962/* Len magic for PERL_MAGIC_tied(P) */
29ecdb6f 963
21312124
NIS
964U32
965sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
966{
967 dTHXc;
29ecdb6f 968 SV *ssv = (SV *) mg->mg_ptr;
21312124
NIS
969 U32 val;
970 SHARED_EDIT;
29ecdb6f 971 if (SvTYPE(ssv) == SVt_PVAV) {
7473853a
SP
972 val = av_len((AV*) ssv);
973 } else {
974 /* Not actually defined by tie API but ... */
975 val = HvKEYS((HV*) ssv);
21312124
NIS
976 }
977 SHARED_RELEASE;
7473853a 978 return (val);
21312124
NIS
979}
980
7473853a 981/* Clear magic for PERL_MAGIC_tied(P) */
29ecdb6f 982
21312124
NIS
983int
984sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
985{
986 dTHXc;
29ecdb6f 987 SV *ssv = (SV *) mg->mg_ptr;
21312124 988 SHARED_EDIT;
29ecdb6f 989 if (SvTYPE(ssv) == SVt_PVAV) {
7473853a
SP
990 av_clear((AV*) ssv);
991 } else {
992 hv_clear((HV*) ssv);
21312124
NIS
993 }
994 SHARED_RELEASE;
7473853a 995 return (0);
21312124
NIS
996}
997
7473853a 998/* Free magic for PERL_MAGIC_tied(P) */
29ecdb6f 999
21312124
NIS
1000int
1001sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
1002{
29ecdb6f 1003 S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr);
7473853a 1004 return (0);
68795e93
NIS
1005}
1006
1007/*
7473853a 1008 * Copy magic for PERL_MAGIC_tied(P)
21312124
NIS
1009 * This is called when perl is about to access an element of
1010 * the array -
1011 */
1012int
1013sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
7473853a 1014 SV *nsv, const char *name, int namlen)
21312124 1015{
21312124 1016 MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
7473853a
SP
1017 toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
1018 name, namlen);
21312124 1019 nmg->mg_flags |= MGf_DUP;
7473853a 1020 return (1);
21312124
NIS
1021}
1022
29ecdb6f
DM
1023/* Called during cloning of PERL_MAGIC_tied(P) magic in new thread */
1024
21312124
NIS
1025int
1026sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
1027{
7473853a 1028 SvREFCNT_inc_void((SV*)mg->mg_ptr);
29ecdb6f 1029 assert(mg->mg_flags & MGf_DUP);
7473853a 1030 return (0);
21312124
NIS
1031}
1032
1033MGVTBL sharedsv_array_vtbl = {
7473853a
SP
1034 0, /* get */
1035 0, /* set */
1036 sharedsv_array_mg_FETCHSIZE,/* len */
1037 sharedsv_array_mg_CLEAR, /* clear */
1038 sharedsv_array_mg_free, /* free */
1039 sharedsv_array_mg_copy, /* copy */
1040 sharedsv_array_mg_dup, /* dup */
1041#ifdef MGf_LOCAL
1042 0, /* local */
1043#endif
21312124
NIS
1044};
1045
1046=for apidoc sharedsv_unlock
68795e93
NIS
1047
1048Recursively unlocks a shared sv.
1049
21312124 1050=cut
68795e93
NIS
1051
1052void
29ecdb6f 1053Perl_sharedsv_unlock(pTHX_ SV *ssv)
68795e93 1054{
29ecdb6f
DM
1055 user_lock *ul = S_get_userlock(aTHX_ ssv, 0);
1056 assert(ul);
1057 recursive_lock_release(aTHX_ &ul->lock);
68795e93
NIS
1058}
1059
21312124 1060=for apidoc sharedsv_lock
68795e93 1061
21312124
NIS
1062Recursive locks on a sharedsv.
1063Locks are dynamically scoped at the level of the first lock.
68795e93 1064
21312124 1065=cut
68795e93
NIS
1066
1067void
29ecdb6f 1068Perl_sharedsv_lock(pTHX_ SV *ssv)
68795e93 1069{
29ecdb6f 1070 user_lock *ul;
7473853a
SP
1071 if (! ssv)
1072 return;
29ecdb6f
DM
1073 ul = S_get_userlock(aTHX_ ssv, 1);
1074 recursive_lock_acquire(aTHX_ &ul->lock, __FILE__, __LINE__);
68795e93
NIS
1075}
1076
7473853a 1077/* Handles calls from lock() builtin via PL_lockhook */
afe38520 1078
21312124
NIS
1079void
1080Perl_sharedsv_locksv(pTHX_ SV *sv)
1081{
29ecdb6f 1082 SV *ssv;
afe38520 1083
7473853a
SP
1084 if (SvROK(sv))
1085 sv = SvRV(sv);
29ecdb6f 1086 ssv = Perl_sharedsv_find(aTHX_ sv);
7473853a 1087 if (!ssv)
afe38520 1088 croak("lock can only be used on shared values");
29ecdb6f 1089 Perl_sharedsv_lock(aTHX_ ssv);
b050c948
AB
1090}
1091
21312124 1092=head1 Shared SV Functions
b050c948 1093
21312124 1094=for apidoc sharedsv_init
b050c948 1095
7473853a 1096Saves a space for keeping SVs wider than an interpreter.
b050c948 1097
21312124
NIS
1098=cut
1099
1100void
1101Perl_sharedsv_init(pTHX)
1102{
7473853a
SP
1103 dTHXc;
1104 /* This pair leaves us in shared context ... */
1105 PL_sharedsv_space = perl_alloc();
1106 perl_construct(PL_sharedsv_space);
1107 CALLER_CONTEXT;
1108 recursive_lock_init(aTHX_ &PL_sharedsv_lock);
1109 PL_lockhook = &Perl_sharedsv_locksv;
1110 PL_sharehook = &Perl_sharedsv_share;
b050c948
AB
1111}
1112
73e09c8f
JH
1113#endif /* USE_ITHREADS */
1114
7473853a 1115MODULE = threads::shared PACKAGE = threads::shared::tie
b050c948 1116
21312124 1117PROTOTYPES: DISABLE
b050c948 1118
73e09c8f 1119#ifdef USE_ITHREADS
6b85e4fe 1120
21312124 1121void
29ecdb6f 1122PUSH(SV *obj, ...)
7473853a
SP
1123 CODE:
1124 dTHXc;
1125 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1126 int i;
1127 for (i = 1; i < items; i++) {
1128 SV* tmp = newSVsv(ST(i));
1129 SV *stmp;
1130 ENTER_LOCK;
1131 stmp = S_sharedsv_new_shared(aTHX_ tmp);
1132 sharedsv_scalar_store(aTHX_ tmp, stmp);
1133 SHARED_CONTEXT;
1134 av_push((AV*) sobj, stmp);
1135 SvREFCNT_inc_void(stmp);
1136 SHARED_RELEASE;
1137 SvREFCNT_dec(tmp);
1138 }
1139
b050c948 1140
21312124 1141void
29ecdb6f 1142UNSHIFT(SV *obj, ...)
7473853a
SP
1143 CODE:
1144 dTHXc;
1145 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1146 int i;
1147 ENTER_LOCK;
1148 SHARED_CONTEXT;
1149 av_unshift((AV*)sobj, items - 1);
1150 CALLER_CONTEXT;
1151 for (i = 1; i < items; i++) {
1152 SV *tmp = newSVsv(ST(i));
1153 SV *stmp = S_sharedsv_new_shared(aTHX_ tmp);
1154 sharedsv_scalar_store(aTHX_ tmp, stmp);
1155 SHARED_CONTEXT;
1156 av_store((AV*) sobj, i - 1, stmp);
1157 SvREFCNT_inc_void(stmp);
1158 CALLER_CONTEXT;
1159 SvREFCNT_dec(tmp);
1160 }
1161 LEAVE_LOCK;
1162
b050c948 1163
21312124 1164void
29ecdb6f 1165POP(SV *obj)
7473853a
SP
1166 CODE:
1167 dTHXc;
1168 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1169 SV* ssv;
1170 ENTER_LOCK;
1171 SHARED_CONTEXT;
1172 ssv = av_pop((AV*)sobj);
1173 CALLER_CONTEXT;
1174 ST(0) = sv_newmortal();
1175 Perl_sharedsv_associate(aTHX_ ST(0), ssv);
1176 SvREFCNT_dec(ssv);
1177 LEAVE_LOCK;
1178 /* XSRETURN(1); - implied */
1179
b050c948 1180
21312124 1181void
29ecdb6f 1182SHIFT(SV *obj)
7473853a
SP
1183 CODE:
1184 dTHXc;
1185 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1186 SV* ssv;
1187 ENTER_LOCK;
1188 SHARED_CONTEXT;
1189 ssv = av_shift((AV*)sobj);
1190 CALLER_CONTEXT;
1191 ST(0) = sv_newmortal();
1192 Perl_sharedsv_associate(aTHX_ ST(0), ssv);
1193 SvREFCNT_dec(ssv);
1194 LEAVE_LOCK;
1195 /* XSRETURN(1); - implied */
1196
b050c948 1197
21312124 1198void
29ecdb6f 1199EXTEND(SV *obj, IV count)
7473853a
SP
1200 CODE:
1201 dTHXc;
1202 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1203 SHARED_EDIT;
1204 av_extend((AV*)sobj, count);
1205 SHARED_RELEASE;
1206
b050c948 1207
21312124 1208void
29ecdb6f 1209STORESIZE(SV *obj,IV count)
7473853a
SP
1210 CODE:
1211 dTHXc;
1212 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1213 SHARED_EDIT;
1214 av_fill((AV*) sobj, count);
1215 SHARED_RELEASE;
6b85e4fe
NIS
1216
1217
1218void
29ecdb6f 1219EXISTS(SV *obj, SV *index)
7473853a
SP
1220 CODE:
1221 dTHXc;
1222 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1223 bool exists;
1224 if (SvTYPE(sobj) == SVt_PVAV) {
1225 SHARED_EDIT;
1226 exists = av_exists((AV*) sobj, SvIV(index));
1227 } else {
1228 STRLEN len;
1229 char *key = SvPV(index,len);
1230 SHARED_EDIT;
1231 exists = hv_exists((HV*) sobj, key, len);
1232 }
1233 SHARED_RELEASE;
1234 ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
1235 /* XSRETURN(1); - implied */
b050c948
AB
1236
1237
1238void
29ecdb6f 1239FIRSTKEY(SV *obj)
7473853a
SP
1240 CODE:
1241 dTHXc;
1242 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1243 char* key = NULL;
1244 I32 len = 0;
1245 HE* entry;
1246 ENTER_LOCK;
1247 SHARED_CONTEXT;
1248 hv_iterinit((HV*) sobj);
1249 entry = hv_iternext((HV*) sobj);
1250 if (entry) {
1251 key = hv_iterkey(entry,&len);
1252 CALLER_CONTEXT;
1253 ST(0) = sv_2mortal(newSVpv(key, len));
1254 } else {
1255 CALLER_CONTEXT;
1256 ST(0) = &PL_sv_undef;
1257 }
1258 LEAVE_LOCK;
1259 /* XSRETURN(1); - implied */
1260
b050c948 1261
866fba46 1262void
29ecdb6f 1263NEXTKEY(SV *obj, SV *oldkey)
7473853a
SP
1264 CODE:
1265 dTHXc;
1266 SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
1267 char* key = NULL;
1268 I32 len = 0;
1269 HE* entry;
1270 ENTER_LOCK;
1271 SHARED_CONTEXT;
1272 entry = hv_iternext((HV*) sobj);
1273 if (entry) {
1274 key = hv_iterkey(entry,&len);
1275 CALLER_CONTEXT;
1276 ST(0) = sv_2mortal(newSVpv(key, len));
1277 } else {
1278 CALLER_CONTEXT;
1279 ST(0) = &PL_sv_undef;
1280 }
1281 LEAVE_LOCK;
1282 /* XSRETURN(1); - implied */
1283
1284
1285MODULE = threads::shared PACKAGE = threads::shared
21312124
NIS
1286
1287PROTOTYPES: ENABLE
866fba46 1288
68795e93 1289void
9c4972d9 1290_id(SV *ref)
7473853a
SP
1291 PROTOTYPE: \[$@%]
1292 PREINIT:
1293 SV *ssv;
1294 CODE:
1295 ref = SvRV(ref);
1296 if (SvROK(ref))
1297 ref = SvRV(ref);
1298 ssv = Perl_sharedsv_find(aTHX_ ref);
1299 if (! ssv)
1300 XSRETURN_UNDEF;
1301 ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv)));
1302 /* XSRETURN(1); - implied */
9c4972d9
NIS
1303
1304
1305void
6b85e4fe 1306_refcnt(SV *ref)
7473853a
SP
1307 PROTOTYPE: \[$@%]
1308 PREINIT:
1309 SV *ssv;
1310 CODE:
1311 ref = SvRV(ref);
1312 if (SvROK(ref))
1313 ref = SvRV(ref);
1314 ssv = Perl_sharedsv_find(aTHX_ ref);
1315 if (! ssv) {
1316 Perl_warn(aTHX_ "%" SVf " is not shared", ST(0));
1317 XSRETURN_UNDEF;
1318 }
1319 ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv)));
1320 /* XSRETURN(1); - implied */
1321
1322
1323void
a446a88f 1324share(SV *ref)
7473853a
SP
1325 PROTOTYPE: \[$@%]
1326 CODE:
1327 if (! SvROK(ref))
56fcff86 1328 Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
7473853a
SP
1329 ref = SvRV(ref);
1330 if (SvROK(ref))
1331 ref = SvRV(ref);
1332 Perl_sharedsv_share(aTHX_ ref);
1333 ST(0) = sv_2mortal(newRV_inc(ref));
1334 /* XSRETURN(1); - implied */
a446a88f 1335
6f942b98
AB
1336
1337void
7473853a
SP
1338cond_wait(SV *ref_cond, SV *ref_lock = 0)
1339 PROTOTYPE: \[$@%];\[$@%]
1340 PREINIT:
1341 SV *ssv;
1342 perl_cond* user_condition;
1343 int locks;
1344 user_lock *ul;
1345 CODE:
1346 if (!SvROK(ref_cond))
56fcff86 1347 Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
7473853a
SP
1348 ref_cond = SvRV(ref_cond);
1349 if (SvROK(ref_cond))
1350 ref_cond = SvRV(ref_cond);
1351 ssv = Perl_sharedsv_find(aTHX_ ref_cond);
1352 if (! ssv)
1353 Perl_croak(aTHX_ "cond_wait can only be used on shared values");
1354 ul = S_get_userlock(aTHX_ ssv, 1);
1355
1356 user_condition = &ul->user_cond;
1357 if (ref_lock && (ref_cond != ref_lock)) {
1358 if (!SvROK(ref_lock))
1359 Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref");
1360 ref_lock = SvRV(ref_lock);
1361 if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1362 ssv = Perl_sharedsv_find(aTHX_ ref_lock);
1363 if (! ssv)
1364 Perl_croak(aTHX_ "cond_wait lock must be a shared value");
1365 ul = S_get_userlock(aTHX_ ssv, 1);
1366 }
1367 if (ul->lock.owner != aTHX)
1368 croak("You need a lock before you can cond_wait");
1369 /* Stealing the members of the lock object worries me - NI-S */
1370 MUTEX_LOCK(&ul->lock.mutex);
1371 ul->lock.owner = NULL;
1372 locks = ul->lock.locks;
1373 ul->lock.locks = 0;
1374
1375 /* Since we are releasing the lock here we need to tell other
1376 * people that is ok to go ahead and use it */
1377 COND_SIGNAL(&ul->lock.cond);
1378 COND_WAIT(user_condition, &ul->lock.mutex);
1379 while(ul->lock.owner != NULL) {
1380 /* OK -- must reacquire the lock */
1381 COND_WAIT(&ul->lock.cond, &ul->lock.mutex);
1382 }
1383 ul->lock.owner = aTHX;
1384 ul->lock.locks = locks;
1385 MUTEX_UNLOCK(&ul->lock.mutex);
1386
a0e036c1
MP
1387
1388int
7473853a
SP
1389cond_timedwait(SV *ref_cond, double abs, SV *ref_lock = 0)
1390 PROTOTYPE: \[$@%]$;\[$@%]
1391 PREINIT:
1392 SV *ssv;
1393 perl_cond* user_condition;
1394 int locks;
1395 user_lock *ul;
1396 CODE:
1397 if (! SvROK(ref_cond))
1398 Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref");
1399 ref_cond = SvRV(ref_cond);
1400 if (SvROK(ref_cond))
1401 ref_cond = SvRV(ref_cond);
1402 ssv = Perl_sharedsv_find(aTHX_ ref_cond);
1403 if (! ssv)
1404 Perl_croak(aTHX_ "cond_timedwait can only be used on shared values");
1405 ul = S_get_userlock(aTHX_ ssv, 1);
1406
1407 user_condition = &ul->user_cond;
1408 if (ref_lock && (ref_cond != ref_lock)) {
1409 if (! SvROK(ref_lock))
1410 Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref");
1411 ref_lock = SvRV(ref_lock);
1412 if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1413 ssv = Perl_sharedsv_find(aTHX_ ref_lock);
1414 if (! ssv)
1415 Perl_croak(aTHX_ "cond_timedwait lock must be a shared value");
1416 ul = S_get_userlock(aTHX_ ssv, 1);
1417 }
1418 if (ul->lock.owner != aTHX)
1419 Perl_croak(aTHX_ "You need a lock before you can cond_wait");
1420
1421 MUTEX_LOCK(&ul->lock.mutex);
1422 ul->lock.owner = NULL;
1423 locks = ul->lock.locks;
1424 ul->lock.locks = 0;
1425 /* Since we are releasing the lock here we need to tell other
1426 * people that is ok to go ahead and use it */
1427 COND_SIGNAL(&ul->lock.cond);
1428 RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs);
1429 while (ul->lock.owner != NULL) {
1430 /* OK -- must reacquire the lock... */
1431 COND_WAIT(&ul->lock.cond, &ul->lock.mutex);
1432 }
1433 ul->lock.owner = aTHX;
1434 ul->lock.locks = locks;
1435 MUTEX_UNLOCK(&ul->lock.mutex);
1436
1437 if (RETVAL == 0)
a0e036c1 1438 XSRETURN_UNDEF;
7473853a
SP
1439 OUTPUT:
1440 RETVAL
a0e036c1 1441
29ecdb6f 1442
7473853a
SP
1443void
1444cond_signal(SV *ref)
1445 PROTOTYPE: \[$@%]
1446 PREINIT:
1447 SV *ssv;
1448 user_lock *ul;
1449 CODE:
1450 if (! SvROK(ref))
56fcff86 1451 Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
7473853a
SP
1452 ref = SvRV(ref);
1453 if (SvROK(ref))
1454 ref = SvRV(ref);
1455 ssv = Perl_sharedsv_find(aTHX_ ref);
1456 if (! ssv)
1457 Perl_croak(aTHX_ "cond_signal can only be used on shared values");
1458 ul = S_get_userlock(aTHX_ ssv, 1);
1459 if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) {
1460 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1461 "cond_signal() called on unlocked variable");
1462 }
1463 COND_SIGNAL(&ul->user_cond);
6f942b98 1464
29ecdb6f 1465
7473853a
SP
1466void
1467cond_broadcast(SV *ref)
1468 PROTOTYPE: \[$@%]
1469 PREINIT:
1470 SV *ssv;
1471 user_lock *ul;
1472 CODE:
1473 if (! SvROK(ref))
56fcff86 1474 Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
7473853a
SP
1475 ref = SvRV(ref);
1476 if (SvROK(ref))
1477 ref = SvRV(ref);
1478 ssv = Perl_sharedsv_find(aTHX_ ref);
1479 if (! ssv)
1480 Perl_croak(aTHX_ "cond_broadcast can only be used on shared values");
1481 ul = S_get_userlock(aTHX_ ssv, 1);
1482 if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) {
1483 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1484 "cond_broadcast() called on unlocked variable");
1485 }
1486 COND_BROADCAST(&ul->user_cond);
1487
1488
1489void
5c360ac5 1490bless(SV* ref, ...);
7473853a
SP
1491 PROTOTYPE: $;$
1492 PREINIT:
1493 HV* stash;
1494 SV *ssv;
1495 CODE:
1496 if (items == 1) {
1497 stash = CopSTASH(PL_curcop);
1498 } else {
1499 SV* classname = ST(1);
1500 STRLEN len;
1501 char *ptr;
1502
1503 if (classname &&
1504 ! SvGMAGICAL(classname) &&
1505 ! SvAMAGIC(classname) &&
1506 SvROK(classname))
1507 {
1508 Perl_croak(aTHX_ "Attempt to bless into a reference");
1509 }
1510 ptr = SvPV(classname, len);
1511 if (ckWARN(WARN_MISC) && len == 0) {
1512 Perl_warner(aTHX_ packWARN(WARN_MISC),
1513 "Explicit blessing to '' (assuming package main)");
1514 }
1515 stash = gv_stashpvn(ptr, len, TRUE);
1516 }
1517 SvREFCNT_inc_void(ref);
1518 (void)sv_bless(ref, stash);
1519 ST(0) = sv_2mortal(ref);
1520 ssv = Perl_sharedsv_find(aTHX_ ref);
1521 if (ssv) {
1522 dTHXc;
1523 ENTER_LOCK;
1524 SHARED_CONTEXT;
1525 {
1526 SV* fake_stash = newSVpv(HvNAME_get(stash), 0);
1527 (void)sv_bless(ssv, (HV*)fake_stash);
1528 }
1529 CALLER_CONTEXT;
1530 LEAVE_LOCK;
1531 }
1532 /* XSRETURN(1); - implied */
5c360ac5 1533
73e09c8f
JH
1534#endif /* USE_ITHREADS */
1535
68795e93
NIS
1536BOOT:
1537{
73e09c8f 1538#ifdef USE_ITHREADS
68795e93 1539 Perl_sharedsv_init(aTHX);
73e09c8f 1540#endif /* USE_ITHREADS */
68795e93 1541}