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