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