This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PATCH: [perl #133882] Assertion failure
[perl5.git] / dist / 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
68795e93 118#define PERL_NO_GET_CONTEXT
b050c948
AB
119#include "EXTERN.h"
120#include "perl.h"
121#include "XSUB.h"
7473853a 122#ifdef HAS_PPPORT_H
39ec4146 123# define NEED_sv_2pv_flags
05b59262
RGS
124# define NEED_vnewSVpvf
125# define NEED_warner
c4393b60 126# define NEED_newSVpvn_flags
7473853a
SP
127# include "ppport.h"
128# include "shared.h"
129#endif
b050c948 130
7347ee54
Z
131#ifndef CLANG_DIAG_IGNORE
132# define CLANG_DIAG_IGNORE(x)
133# define CLANG_DIAG_RESTORE
134#endif
135#ifndef CLANG_DIAG_IGNORE_STMT
136# define CLANG_DIAG_IGNORE_STMT(x) CLANG_DIAG_IGNORE(x) NOOP
137# define CLANG_DIAG_RESTORE_STMT CLANG_DIAG_RESTORE NOOP
138#endif
139
73e09c8f
JH
140#ifdef USE_ITHREADS
141
e21694ed
JH
142/* Magic signature(s) for mg_private to make PERL_MAGIC_ext magic safer */
143#define UL_MAGIC_SIG 0x554C /* UL = user lock */
144
21312124 145/*
c4a6f826 146 * The shared things need an interpreter to live in ...
21312124 147 */
47b62f63 148static PerlInterpreter *PL_sharedsv_space; /* The shared sv space */
21312124 149/* To access shared space we fake aTHX in this scope and thread's context */
057e91b3 150
7473853a
SP
151/* Bug #24255: We include ENTER+SAVETMPS/FREETMPS+LEAVE with
152 * SHARED_CONTEXT/CALLER_CONTEXT macros, so that any mortals, etc. created
1011f542 153 * while in the shared interpreter context don't languish */
057e91b3 154
7473853a
SP
155#define SHARED_CONTEXT \
156 STMT_START { \
157 PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); \
158 ENTER; \
159 SAVETMPS; \
057e91b3 160 } STMT_END
21312124
NIS
161
162/* So we need a way to switch back to the caller's context... */
163/* So we declare _another_ copy of the aTHX variable ... */
164#define dTHXc PerlInterpreter *caller_perl = aTHX
057e91b3 165
7473853a
SP
166/* ... and use it to switch back */
167#define CALLER_CONTEXT \
168 STMT_START { \
169 FREETMPS; \
170 LEAVE; \
171 PERL_SET_CONTEXT((aTHX = caller_perl)); \
057e91b3 172 } STMT_END
21312124
NIS
173
174/*
175 * Only one thread at a time is allowed to mess with shared space.
176 */
a446a88f 177
7473853a
SP
178typedef struct {
179 perl_mutex mutex;
180 PerlInterpreter *owner;
181 I32 locks;
182 perl_cond cond;
6b85e4fe 183#ifdef DEBUG_LOCKS
e0707a4a 184 const char * file;
7473853a 185 int line;
6b85e4fe 186#endif
6d56dc1c
NIS
187} recursive_lock_t;
188
47b62f63 189static recursive_lock_t PL_sharedsv_lock; /* Mutex protecting the shared sv space */
6d56dc1c 190
0b057af7 191static void
6d56dc1c
NIS
192recursive_lock_init(pTHX_ recursive_lock_t *lock)
193{
194 Zero(lock,1,recursive_lock_t);
195 MUTEX_INIT(&lock->mutex);
196 COND_INIT(&lock->cond);
197}
198
0b057af7 199static void
579f9913
AB
200recursive_lock_destroy(pTHX_ recursive_lock_t *lock)
201{
202 MUTEX_DESTROY(&lock->mutex);
203 COND_DESTROY(&lock->cond);
204}
205
0b057af7 206static void
6d56dc1c
NIS
207recursive_lock_release(pTHX_ recursive_lock_t *lock)
208{
209 MUTEX_LOCK(&lock->mutex);
ba2940ce
JH
210 if (lock->owner == aTHX) {
211 if (--lock->locks == 0) {
212 lock->owner = NULL;
213 COND_SIGNAL(&lock->cond);
214 }
6d56dc1c
NIS
215 }
216 MUTEX_UNLOCK(&lock->mutex);
217}
a446a88f 218
0b057af7 219static void
e0707a4a 220recursive_lock_acquire(pTHX_ recursive_lock_t *lock, const char *file, int line)
6d56dc1c 221{
c33e8be1
Z
222 PERL_UNUSED_ARG(file);
223 PERL_UNUSED_ARG(line);
6d56dc1c
NIS
224 assert(aTHX);
225 MUTEX_LOCK(&lock->mutex);
226 if (lock->owner == aTHX) {
7473853a
SP
227 lock->locks++;
228 } else {
229 while (lock->owner) {
6b85e4fe 230#ifdef DEBUG_LOCKS
7473853a
SP
231 Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n",
232 aTHX, lock->owner, lock->file, lock->line);
6b85e4fe 233#endif
7473853a 234 COND_WAIT(&lock->cond,&lock->mutex);
6b85e4fe 235 }
7473853a
SP
236 lock->locks = 1;
237 lock->owner = aTHX;
6b85e4fe 238#ifdef DEBUG_LOCKS
7473853a
SP
239 lock->file = file;
240 lock->line = line;
6b85e4fe 241#endif
6d56dc1c
NIS
242 }
243 MUTEX_UNLOCK(&lock->mutex);
6b85e4fe 244 SAVEDESTRUCTOR_X(recursive_lock_release,lock);
6d56dc1c
NIS
245}
246
7473853a
SP
247#define ENTER_LOCK \
248 STMT_START { \
249 ENTER; \
250 recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__);\
251 } STMT_END
21312124 252
7473853a
SP
253/* The unlocking is done automatically at scope exit */
254#define LEAVE_LOCK LEAVE
6d56dc1c 255
21312124
NIS
256
257/* A common idiom is to acquire access and switch in ... */
7473853a
SP
258#define SHARED_EDIT \
259 STMT_START { \
260 ENTER_LOCK; \
261 SHARED_CONTEXT; \
262 } STMT_END
21312124 263
7473853a
SP
264/* ... then switch out and release access. */
265#define SHARED_RELEASE \
266 STMT_START { \
267 CALLER_CONTEXT; \
268 LEAVE_LOCK; \
269 } STMT_END
85e0a142 270
21312124 271
7473853a 272/* User-level locks:
29ecdb6f
DM
273 This structure is attached (using ext magic) to any shared SV that
274 is used by user-level locking or condition code
21312124 275*/
68795e93
NIS
276
277typedef struct {
7473853a 278 recursive_lock_t lock; /* For user-levl locks */
68795e93 279 perl_cond user_cond; /* For user-level conditions */
29ecdb6f 280} user_lock;
68795e93 281
7473853a 282/* Magic used for attaching user_lock structs to shared SVs
68795e93 283
21312124
NIS
284 The vtable used has just one entry - when the SV goes away
285 we free the memory for the above.
21312124 286 */
68795e93 287
0b057af7 288static int
29ecdb6f 289sharedsv_userlock_free(pTHX_ SV *sv, MAGIC *mg)
21312124 290{
29ecdb6f 291 user_lock *ul = (user_lock *) mg->mg_ptr;
c33e8be1 292 PERL_UNUSED_ARG(sv);
29ecdb6f
DM
293 assert(aTHX == PL_sharedsv_space);
294 if (ul) {
7473853a
SP
295 recursive_lock_destroy(aTHX_ &ul->lock);
296 COND_DESTROY(&ul->user_cond);
297 PerlMemShared_free(ul);
298 mg->mg_ptr = NULL;
21312124 299 }
7473853a 300 return (0);
21312124
NIS
301}
302
47b62f63 303static const MGVTBL sharedsv_userlock_vtbl = {
7473853a
SP
304 0, /* get */
305 0, /* set */
306 0, /* len */
307 0, /* clear */
308 sharedsv_userlock_free, /* free */
309 0, /* copy */
310 0, /* dup */
311#ifdef MGf_LOCAL
312 0, /* local */
313#endif
21312124
NIS
314};
315
28399f57
JH
316
317/* Support for dual-valued variables */
318#ifdef SVf_IVisUV
319# define DUALVAR_FLAGS(sv) \
320 ((SvPOK(sv)) \
321 ? ((SvNOK(sv) || SvNOKp(sv)) ? SVf_NOK \
322 : ((SvIsUV(sv)) ? (SVf_IOK | SVf_IVisUV) \
323 : ((SvIOK(sv) || SvIOKp(sv)) ? SVf_IOK : 0))) \
324 : 0)
325#else
326# define DUALVAR_FLAGS(sv) \
327 ((SvPOK(sv)) \
328 ? ((SvNOK(sv) || SvNOKp(sv)) ? SVf_NOK \
329 : ((SvIOK(sv) || SvIOKp(sv)) ? SVf_IOK : 0)) \
330 : 0)
331#endif
332
333
7473853a
SP
334/*
335 * Access to shared things is heavily based on MAGIC
336 * - in mg.h/mg.c/sv.c sense
337 */
21312124
NIS
338
339/* In any thread that has access to a shared thing there is a "proxy"
340 for it in its own space which has 'MAGIC' associated which accesses
341 the shared thing.
342 */
343
47b62f63
DD
344extern const MGVTBL sharedsv_scalar_vtbl; /* Scalars have this vtable */
345extern const MGVTBL sharedsv_array_vtbl; /* Hashes and arrays have this
3bc7ad01 346 - like 'tie' */
47b62f63 347extern const MGVTBL sharedsv_elem_vtbl; /* Elements of hashes and arrays have
3bc7ad01 348 this _AS WELL AS_ the scalar magic:
29ecdb6f 349 The sharedsv_elem_vtbl associates the element with the array/hash and
21312124
NIS
350 the sharedsv_scalar_vtbl associates it with the value
351 */
352
6b85e4fe 353
7473853a 354/* Get shared aggregate SV pointed to by threads::shared::tie magic object */
29ecdb6f 355
28399f57 356#define SHAREDSV_FROM_OBJ(sv) ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL)
29ecdb6f
DM
357
358
359/* Return the user_lock structure (if any) associated with a shared SV.
7473853a
SP
360 * If create is true, create one if it doesn't exist
361 */
29ecdb6f
DM
362STATIC user_lock *
363S_get_userlock(pTHX_ SV* ssv, bool create)
364{
365 MAGIC *mg;
366 user_lock *ul = NULL;
367
368 assert(ssv);
7473853a 369 /* XXX Redesign the storage of user locks so we don't need a global
29ecdb6f
DM
370 * lock to access them ???? DAPM */
371 ENTER_LOCK;
e21694ed
JH
372
373 /* Version of mg_find that also checks the private signature */
374 for (mg = SvMAGIC(ssv); mg; mg = mg->mg_moremagic) {
375 if ((mg->mg_type == PERL_MAGIC_ext) &&
376 (mg->mg_private == UL_MAGIC_SIG))
377 {
378 break;
379 }
380 }
381
7473853a
SP
382 if (mg) {
383 ul = (user_lock*)(mg->mg_ptr);
384 } else if (create) {
385 dTHXc;
386 SHARED_CONTEXT;
387 ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock));
388 Zero(ul, 1, user_lock);
389 /* Attach to shared SV using ext magic */
e21694ed
JH
390 mg = sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl,
391 (char *)ul, 0);
392 mg->mg_private = UL_MAGIC_SIG; /* Set private signature */
7473853a
SP
393 recursive_lock_init(aTHX_ &ul->lock);
394 COND_INIT(&ul->user_cond);
395 CALLER_CONTEXT;
29ecdb6f
DM
396 }
397 LEAVE_LOCK;
7473853a 398 return (ul);
6b85e4fe
NIS
399}
400
29ecdb6f 401
ba2940ce
JH
402/* Given a private side SV tries to find if the SV has a shared backend,
403 * by looking for the magic.
404 */
0b057af7 405static SV *
21312124
NIS
406Perl_sharedsv_find(pTHX_ SV *sv)
407{
408 MAGIC *mg;
a446a88f 409 if (SvTYPE(sv) >= SVt_PVMG) {
7473853a
SP
410 switch(SvTYPE(sv)) {
411 case SVt_PVAV:
412 case SVt_PVHV:
413 if ((mg = mg_find(sv, PERL_MAGIC_tied))
414 && mg->mg_virtual == &sharedsv_array_vtbl) {
415 return ((SV *)mg->mg_ptr);
416 }
417 break;
418 default:
419 /* This should work for elements as well as they
420 * have scalar magic as well as their element magic
421 */
422 if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar))
423 && mg->mg_virtual == &sharedsv_scalar_vtbl) {
424 return ((SV *)mg->mg_ptr);
425 }
426 break;
427 }
21312124 428 }
6b85e4fe
NIS
429 /* Just for tidyness of API also handle tie objects */
430 if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) {
28399f57 431 return (SHAREDSV_FROM_OBJ(sv));
6b85e4fe 432 }
7473853a 433 return (NULL);
21312124 434}
68795e93 435
68795e93 436
7473853a
SP
437/* Associate a private SV with a shared SV by pointing the appropriate
438 * magics at it.
439 * Assumes lock is held.
440 */
0b057af7 441static void
29ecdb6f 442Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv)
21312124 443{
a446a88f 444 MAGIC *mg = 0;
a446a88f 445
29ecdb6f 446 /* If we are asked for any private ops we need a thread */
a446a88f
NIS
447 assert ( aTHX != PL_sharedsv_space );
448
449 /* To avoid need for recursive locks require caller to hold lock */
6d56dc1c 450 assert ( PL_sharedsv_lock.owner == aTHX );
6b85e4fe 451
29ecdb6f
DM
452 switch(SvTYPE(sv)) {
453 case SVt_PVAV:
454 case SVt_PVHV:
7473853a
SP
455 if (!(mg = mg_find(sv, PERL_MAGIC_tied))
456 || mg->mg_virtual != &sharedsv_array_vtbl
457 || (SV*) mg->mg_ptr != ssv)
458 {
459 SV *obj = newSV(0);
460 sv_setref_iv(obj, "threads::shared::tie", PTR2IV(ssv));
461 if (mg) {
462 sv_unmagic(sv, PERL_MAGIC_tied);
463 }
464 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
465 (char *)ssv, 0);
466 mg->mg_flags |= (MGf_COPY|MGf_DUP);
467 SvREFCNT_inc_void(ssv);
468 SvREFCNT_dec(obj);
469 }
470 break;
68795e93 471
29ecdb6f 472 default:
7473853a
SP
473 if ((SvTYPE(sv) < SVt_PVMG)
474 || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar))
475 || mg->mg_virtual != &sharedsv_scalar_vtbl
476 || (SV*) mg->mg_ptr != ssv)
477 {
478 if (mg) {
479 sv_unmagic(sv, PERL_MAGIC_shared_scalar);
480 }
481 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
482 &sharedsv_scalar_vtbl, (char *)ssv, 0);
483 mg->mg_flags |= (MGf_DUP
484#ifdef MGf_LOCAL
485 |MGf_LOCAL
486#endif
487 );
488 SvREFCNT_inc_void(ssv);
489 }
490 break;
21312124 491 }
7473853a 492
29ecdb6f
DM
493 assert ( Perl_sharedsv_find(aTHX_ sv) == ssv );
494}
6b85e4fe 495
6b85e4fe 496
29ecdb6f 497/* Given a private SV, create and return an associated shared SV.
7473853a
SP
498 * Assumes lock is held.
499 */
29ecdb6f
DM
500STATIC SV *
501S_sharedsv_new_shared(pTHX_ SV *sv)
502{
503 dTHXc;
504 SV *ssv;
6b85e4fe 505
29ecdb6f
DM
506 assert(PL_sharedsv_lock.owner == aTHX);
507 assert(aTHX != PL_sharedsv_space);
68795e93 508
29ecdb6f
DM
509 SHARED_CONTEXT;
510 ssv = newSV(0);
7473853a 511 SvREFCNT(ssv) = 0; /* Will be upped to 1 by Perl_sharedsv_associate */
29ecdb6f
DM
512 sv_upgrade(ssv, SvTYPE(sv));
513 CALLER_CONTEXT;
514 Perl_sharedsv_associate(aTHX_ sv, ssv);
7473853a 515 return (ssv);
29ecdb6f 516}
21312124 517
21312124 518
29ecdb6f 519/* Given a shared SV, create and return an associated private SV.
7473853a
SP
520 * Assumes lock is held.
521 */
29ecdb6f
DM
522STATIC SV *
523S_sharedsv_new_private(pTHX_ SV *ssv)
524{
525 SV *sv;
526
527 assert(PL_sharedsv_lock.owner == aTHX);
528 assert(aTHX != PL_sharedsv_space);
529
530 sv = newSV(0);
531 sv_upgrade(sv, SvTYPE(ssv));
532 Perl_sharedsv_associate(aTHX_ sv, ssv);
7473853a 533 return (sv);
21312124 534}
68795e93 535
29ecdb6f 536
7473853a 537/* A threadsafe version of SvREFCNT_dec(ssv) */
29ecdb6f
DM
538
539STATIC void
540S_sharedsv_dec(pTHX_ SV* ssv)
68795e93 541{
7473853a
SP
542 if (! ssv)
543 return;
29ecdb6f
DM
544 ENTER_LOCK;
545 if (SvREFCNT(ssv) > 1) {
7473853a
SP
546 /* No side effects, so can do it lightweight */
547 SvREFCNT_dec(ssv);
548 } else {
549 dTHXc;
550 SHARED_CONTEXT;
551 SvREFCNT_dec(ssv);
552 CALLER_CONTEXT;
21312124 553 }
29ecdb6f 554 LEAVE_LOCK;
68795e93
NIS
555}
556
7473853a
SP
557
558/* Implements Perl-level share() and :shared */
29ecdb6f 559
0b057af7 560static void
21312124
NIS
561Perl_sharedsv_share(pTHX_ SV *sv)
562{
563 switch(SvTYPE(sv)) {
564 case SVt_PVGV:
7473853a
SP
565 Perl_croak(aTHX_ "Cannot share globs yet");
566 break;
21312124
NIS
567
568 case SVt_PVCV:
7473853a
SP
569 Perl_croak(aTHX_ "Cannot share subs yet");
570 break;
85e0a142 571
21312124 572 default:
7473853a
SP
573 ENTER_LOCK;
574 (void) S_sharedsv_new_shared(aTHX_ sv);
575 LEAVE_LOCK;
576 SvSETMAGIC(sv);
577 break;
21312124
NIS
578 }
579}
68795e93 580
7473853a 581
2a6601ce
RGS
582#ifdef WIN32
583/* Number of milliseconds from 1/1/1601 to 1/1/1970 */
584#define EPOCH_BIAS 11644473600000.
585
586/* Returns relative time in milliseconds. (Adapted from Time::HiRes.) */
587STATIC DWORD
588S_abs_2_rel_milli(double abs)
589{
590 double rel;
591
592 /* Get current time (in units of 100 nanoseconds since 1/1/1601) */
593 union {
05b59262
RGS
594 FILETIME ft;
595 __int64 i64; /* 'signed' to keep compilers happy */
2a6601ce
RGS
596 } now;
597
598 GetSystemTimeAsFileTime(&now.ft);
599
600 /* Relative time in milliseconds */
601 rel = (abs * 1000.) - (((double)now.i64 / 10000.) - EPOCH_BIAS);
2a6601ce
RGS
602 if (rel <= 0.0) {
603 return (0);
604 }
605 return (DWORD)rel;
606}
607
608#else
609# if defined(OS2)
7473853a 610# define ABS2RELMILLI(abs) \
a0e036c1 611 do { \
2666606c 612 abs -= (double)time(NULL); \
a0e036c1
MP
613 if (abs > 0) { abs *= 1000; } \
614 else { abs = 0; } \
615 } while (0)
2a6601ce
RGS
616# endif /* OS2 */
617#endif /* WIN32 */
a0e036c1 618
7473853a 619/* Do OS-specific condition timed wait */
29ecdb6f 620
0b057af7 621static bool
a0e036c1
MP
622Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs)
623{
ef4abe76 624#if defined(NETWARE) || defined(I_MACH_CTHREADS)
a0e036c1
MP
625 Perl_croak_nocontext("cond_timedwait not supported on this platform");
626#else
627# ifdef WIN32
628 int got_it = 0;
629
a0e036c1
MP
630 cond->waiters++;
631 MUTEX_UNLOCK(mut);
632 /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */
2a6601ce 633 switch (WaitForSingleObject(cond->sem, S_abs_2_rel_milli(abs))) {
a0e036c1
MP
634 case WAIT_OBJECT_0: got_it = 1; break;
635 case WAIT_TIMEOUT: break;
636 default:
637 /* WAIT_FAILED? WAIT_ABANDONED? others? */
638 Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError());
639 break;
640 }
641 MUTEX_LOCK(mut);
2666606c 642 cond->waiters--;
7473853a 643 return (got_it);
a0e036c1
MP
644# else
645# ifdef OS2
646 int rc, got_it = 0;
647 STRLEN n_a;
648
649 ABS2RELMILLI(abs);
650
651 if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET))
652 Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset");
653 MUTEX_UNLOCK(mut);
654 if (CheckOSError(DosWaitEventSem(*cond,abs))
655 && (rc != ERROR_INTERRUPT))
656 croak_with_os2error("panic: cond_timedwait");
657 if (rc == ERROR_INTERRUPT) errno = EINTR;
658 MUTEX_LOCK(mut);
7473853a
SP
659 return (got_it);
660# else /* Hope you're I_PTHREAD! */
a0e036c1
MP
661 struct timespec ts;
662 int got_it = 0;
663
664 ts.tv_sec = (long)abs;
665 abs -= (NV)ts.tv_sec;
666 ts.tv_nsec = (long)(abs * 1000000000.0);
667
7347ee54 668 CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
58e76350 669 /* warning: calling function 'pthread_cond_timedwait' requires holding mutex 'mut' exclusively [-Wthread-safety-analysis] */
a0e036c1 670 switch (pthread_cond_timedwait(cond, mut, &ts)) {
7347ee54 671 CLANG_DIAG_RESTORE_STMT;
58e76350 672
a0e036c1
MP
673 case 0: got_it = 1; break;
674 case ETIMEDOUT: break;
cf0d1c66
JH
675#ifdef OEMVS
676 case -1:
7473853a
SP
677 if (errno == ETIMEDOUT || errno == EAGAIN)
678 break;
cf0d1c66 679#endif
a0e036c1
MP
680 default:
681 Perl_croak_nocontext("panic: cond_timedwait");
682 break;
683 }
7473853a 684 return (got_it);
a0e036c1
MP
685# endif /* OS2 */
686# endif /* WIN32 */
ef4abe76 687#endif /* NETWARE || I_MACH_CTHREADS */
a0e036c1
MP
688}
689
dad67c22 690
ab3a355e
FC
691/* Given a thingy referenced by a shared RV, copy it's value to a private
692 * RV, also copying the object status of the referent.
dad67c22
DM
693 * If the private side is already an appropriate RV->SV combination, keep
694 * it if possible.
695 */
dad67c22 696STATIC void
ab3a355e 697S_get_RV(pTHX_ SV *sv, SV *sobj) {
dad67c22 698 SV *obj;
7473853a
SP
699 if (! (SvROK(sv) &&
700 ((obj = SvRV(sv))) &&
701 (Perl_sharedsv_find(aTHX_ obj) == sobj) &&
702 (SvTYPE(obj) == SvTYPE(sobj))))
dad67c22 703 {
7473853a
SP
704 /* Can't reuse obj */
705 if (SvROK(sv)) {
706 SvREFCNT_dec(SvRV(sv));
707 } else {
708 assert(SvTYPE(sv) >= SVt_RV);
709 sv_setsv_nomg(sv, &PL_sv_undef);
710 SvROK_on(sv);
711 }
ab3a355e 712 obj = S_sharedsv_new_private(aTHX_ sobj);
7473853a 713 SvRV_set(sv, obj);
dad67c22
DM
714 }
715
716 if (SvOBJECT(obj)) {
7473853a
SP
717 /* Remove any old blessing */
718 SvREFCNT_dec(SvSTASH(obj));
719 SvOBJECT_off(obj);
dad67c22
DM
720 }
721 if (SvOBJECT(sobj)) {
7473853a
SP
722 /* Add any new old blessing */
723 STRLEN len;
724 char* stash_ptr = SvPV((SV*) SvSTASH(sobj), len);
725 HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
726 SvOBJECT_on(obj);
727 SvSTASH_set(obj, (HV*)SvREFCNT_inc(stash));
dad67c22
DM
728 }
729}
730
ab3a355e
FC
731/* Every caller of S_get_RV needs this incantation (which cannot go inside
732 S_get_RV itself, as we do not want recursion beyond one level): */
733#define get_RV(sv, sobj) \
734 S_get_RV(aTHX_ sv, sobj); \
735 /* Look ahead for refs of refs */ \
736 if (SvROK(sobj)) { \
737 SvROK_on(SvRV(sv)); \
738 S_get_RV(aTHX_ SvRV(sv), SvRV(sobj)); \
739 }
740
dad67c22 741
29ecdb6f
DM
742/* ------------ PERL_MAGIC_shared_scalar(n) functions -------------- */
743
7473853a 744/* Get magic for PERL_MAGIC_shared_scalar(n) */
68795e93 745
0b057af7 746static int
21312124 747sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
68795e93 748{
29ecdb6f
DM
749 SV *ssv = (SV *) mg->mg_ptr;
750 assert(ssv);
21312124 751
6d56dc1c 752 ENTER_LOCK;
29ecdb6f 753 if (SvROK(ssv)) {
ab3a355e 754 get_RV(sv, SvRV(ssv));
7473853a
SP
755 } else {
756 sv_setsv_nomg(sv, ssv);
21312124 757 }
6d56dc1c 758 LEAVE_LOCK;
7473853a 759 return (0);
21312124
NIS
760}
761
7473853a
SP
762/* Copy the contents of a private SV to a shared SV.
763 * Used by various mg_set()-type functions.
764 * Assumes lock is held.
765 */
0b057af7 766static void
29ecdb6f 767sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv)
21312124
NIS
768{
769 dTHXc;
21312124 770 bool allowed = TRUE;
29ecdb6f
DM
771
772 assert(PL_sharedsv_lock.owner == aTHX);
7d585d2f
FC
773 if (!PL_dirty && SvROK(ssv) && SvREFCNT(SvRV(ssv)) == 1) {
774 SV *sv = sv_newmortal();
775 sv_upgrade(sv, SVt_RV);
776 get_RV(sv, SvRV(ssv));
777 }
21312124 778 if (SvROK(sv)) {
7473853a
SP
779 SV *obj = SvRV(sv);
780 SV *sobj = Perl_sharedsv_find(aTHX_ obj);
781 if (sobj) {
782 SHARED_CONTEXT;
2a6601ce 783 (void)SvUPGRADE(ssv, SVt_RV);
7473853a
SP
784 sv_setsv_nomg(ssv, &PL_sv_undef);
785
786 SvRV_set(ssv, SvREFCNT_inc(sobj));
787 SvROK_on(ssv);
788 if (SvOBJECT(sobj)) {
789 /* Remove any old blessing */
790 SvREFCNT_dec(SvSTASH(sobj));
791 SvOBJECT_off(sobj);
792 }
793 if (SvOBJECT(obj)) {
794 SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(obj)),0);
795 SvOBJECT_on(sobj);
796 SvSTASH_set(sobj, (HV*)fake_stash);
797 }
798 CALLER_CONTEXT;
799 } else {
800 allowed = FALSE;
801 }
802 } else {
5c360ac5 803 SvTEMP_off(sv);
7473853a
SP
804 SHARED_CONTEXT;
805 sv_setsv_nomg(ssv, sv);
806 if (SvOBJECT(ssv)) {
807 /* Remove any old blessing */
808 SvREFCNT_dec(SvSTASH(ssv));
809 SvOBJECT_off(ssv);
810 }
811 if (SvOBJECT(sv)) {
812 SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0);
813 SvOBJECT_on(ssv);
814 SvSTASH_set(ssv, (HV*)fake_stash);
815 }
816 CALLER_CONTEXT;
21312124 817 }
21312124 818 if (!allowed) {
7473853a 819 Perl_croak(aTHX_ "Invalid value for shared scalar");
21312124 820 }
6b85e4fe
NIS
821}
822
7473853a 823/* Set magic for PERL_MAGIC_shared_scalar(n) */
29ecdb6f 824
0b057af7 825static int
6b85e4fe
NIS
826sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
827{
29ecdb6f
DM
828 SV *ssv = (SV*)(mg->mg_ptr);
829 assert(ssv);
6b85e4fe 830 ENTER_LOCK;
29ecdb6f 831 if (SvTYPE(ssv) < SvTYPE(sv)) {
7473853a
SP
832 dTHXc;
833 SHARED_CONTEXT;
834 sv_upgrade(ssv, SvTYPE(sv));
835 CALLER_CONTEXT;
29ecdb6f
DM
836 }
837 sharedsv_scalar_store(aTHX_ sv, ssv);
6b85e4fe 838 LEAVE_LOCK;
7473853a 839 return (0);
68795e93
NIS
840}
841
7473853a 842/* Free magic for PERL_MAGIC_shared_scalar(n) */
a446a88f 843
0b057af7 844static int
29ecdb6f 845sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
a446a88f 846{
c33e8be1 847 PERL_UNUSED_ARG(sv);
7d585d2f
FC
848 ENTER_LOCK;
849 if (!PL_dirty
850 && SvROK((SV *)mg->mg_ptr) && SvREFCNT(SvRV((SV *)mg->mg_ptr)) == 1) {
851 SV *sv = sv_newmortal();
852 sv_upgrade(sv, SVt_RV);
853 get_RV(sv, SvRV((SV *)mg->mg_ptr));
854 }
29ecdb6f 855 S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr);
7d585d2f 856 LEAVE_LOCK;
7473853a 857 return (0);
21312124 858}
68795e93
NIS
859
860/*
29ecdb6f 861 * Called during cloning of PERL_MAGIC_shared_scalar(n) magic in new thread
21312124 862 */
0b057af7 863static int
21312124
NIS
864sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
865{
c33e8be1 866 PERL_UNUSED_ARG(param);
7473853a
SP
867 SvREFCNT_inc_void(mg->mg_ptr);
868 return (0);
21312124 869}
68795e93 870
7473853a 871#ifdef MGf_LOCAL
a5063e7c
DM
872/*
873 * Called during local $shared
874 */
0b057af7 875static int
a5063e7c
DM
876sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg)
877{
878 MAGIC *nmg;
29ecdb6f
DM
879 SV *ssv = (SV *) mg->mg_ptr;
880 if (ssv) {
7473853a
SP
881 ENTER_LOCK;
882 SvREFCNT_inc_void(ssv);
883 LEAVE_LOCK;
a5063e7c
DM
884 }
885 nmg = sv_magicext(nsv, mg->mg_obj, mg->mg_type, mg->mg_virtual,
7473853a 886 mg->mg_ptr, mg->mg_len);
a5063e7c
DM
887 nmg->mg_flags = mg->mg_flags;
888 nmg->mg_private = mg->mg_private;
889
7473853a 890 return (0);
a5063e7c 891}
7473853a 892#endif
a5063e7c 893
eeb9a2fc 894const MGVTBL sharedsv_scalar_vtbl = {
7473853a
SP
895 sharedsv_scalar_mg_get, /* get */
896 sharedsv_scalar_mg_set, /* set */
897 0, /* len */
898 0, /* clear */
899 sharedsv_scalar_mg_free, /* free */
900 0, /* copy */
901 sharedsv_scalar_mg_dup, /* dup */
902#ifdef MGf_LOCAL
903 sharedsv_scalar_mg_local, /* local */
904#endif
21312124 905};
68795e93 906
29ecdb6f
DM
907/* ------------ PERL_MAGIC_tiedelem(p) functions -------------- */
908
7473853a 909/* Get magic for PERL_MAGIC_tiedelem(p) */
29ecdb6f 910
0b057af7 911static int
21312124 912sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
68795e93 913{
21312124 914 dTHXc;
28399f57 915 SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj);
1a3f0f1d 916 SV** svp = NULL;
21312124 917
6b85e4fe 918 ENTER_LOCK;
1a3f0f1d
SM
919 if (saggregate) { /* During global destruction, underlying
920 aggregate may no longer exist */
921 if (SvTYPE(saggregate) == SVt_PVAV) {
922 assert ( mg->mg_ptr == 0 );
923 SHARED_CONTEXT;
924 svp = av_fetch((AV*) saggregate, mg->mg_len, 0);
925 } else {
926 char *key = mg->mg_ptr;
927 I32 len = mg->mg_len;
928 assert ( mg->mg_ptr != 0 );
929 if (mg->mg_len == HEf_SVKEY) {
930 STRLEN slen;
931 key = SvPV((SV *)mg->mg_ptr, slen);
932 len = slen;
933 if (SvUTF8((SV *)mg->mg_ptr)) {
934 len = -len;
935 }
a1335164 936 }
1a3f0f1d
SM
937 SHARED_CONTEXT;
938 svp = hv_fetch((HV*) saggregate, key, len, 0);
7473853a 939 }
1a3f0f1d 940 CALLER_CONTEXT;
21312124 941 }
21312124 942 if (svp) {
7473853a
SP
943 /* Exists in the array */
944 if (SvROK(*svp)) {
ab3a355e 945 get_RV(sv, SvRV(*svp));
7473853a 946 } else {
373098c0 947 /* $ary->[elem] or $ary->{elem} is a scalar */
7473853a
SP
948 Perl_sharedsv_associate(aTHX_ sv, *svp);
949 sv_setsv(sv, *svp);
950 }
951 } else {
952 /* Not in the array */
953 sv_setsv(sv, &PL_sv_undef);
68795e93 954 }
6b85e4fe 955 LEAVE_LOCK;
7473853a 956 return (0);
68795e93
NIS
957}
958
7473853a 959/* Set magic for PERL_MAGIC_tiedelem(p) */
29ecdb6f 960
0b057af7 961static int
21312124
NIS
962sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
963{
964 dTHXc;
28399f57 965 SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj);
6b85e4fe 966 SV **svp;
28399f57
JH
967 U32 dualvar_flags = DUALVAR_FLAGS(sv);
968
21312124
NIS
969 /* Theory - SV itself is magically shared - and we have ordered the
970 magic such that by the time we get here it has been stored
971 to its shared counterpart
972 */
6d56dc1c 973 ENTER_LOCK;
29ecdb6f
DM
974 assert(saggregate);
975 if (SvTYPE(saggregate) == SVt_PVAV) {
7473853a
SP
976 assert ( mg->mg_ptr == 0 );
977 SHARED_CONTEXT;
978 svp = av_fetch((AV*) saggregate, mg->mg_len, 1);
979 } else {
980 char *key = mg->mg_ptr;
39b6627f 981 I32 len = mg->mg_len;
7473853a 982 assert ( mg->mg_ptr != 0 );
a1335164 983 if (mg->mg_len == HEf_SVKEY) {
7600f30e
JH
984 STRLEN slen;
985 key = SvPV((SV *)mg->mg_ptr, slen);
986 len = slen;
a1335164
JH
987 if (SvUTF8((SV *)mg->mg_ptr)) {
988 len = -len;
989 }
990 }
7473853a
SP
991 SHARED_CONTEXT;
992 svp = hv_fetch((HV*) saggregate, key, len, 1);
21312124 993 }
6b85e4fe 994 CALLER_CONTEXT;
29ecdb6f
DM
995 Perl_sharedsv_associate(aTHX_ sv, *svp);
996 sharedsv_scalar_store(aTHX_ sv, *svp);
28399f57 997 SvFLAGS(*svp) |= dualvar_flags;
6b85e4fe 998 LEAVE_LOCK;
7473853a 999 return (0);
21312124 1000}
68795e93 1001
7473853a 1002/* Clear magic for PERL_MAGIC_tiedelem(p) */
29ecdb6f 1003
0b057af7 1004static int
21312124 1005sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
68795e93 1006{
21312124 1007 dTHXc;
057e91b3 1008 MAGIC *shmg;
28399f57 1009 SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj);
1a3f0f1d
SM
1010
1011 /* Object may not exist during global destruction */
1012 if (! saggregate) {
1013 return (0);
1014 }
1015
6b85e4fe
NIS
1016 ENTER_LOCK;
1017 sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
057e91b3 1018 if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
7473853a 1019 sharedsv_scalar_mg_get(aTHX_ sv, shmg);
29ecdb6f 1020 if (SvTYPE(saggregate) == SVt_PVAV) {
7473853a
SP
1021 SHARED_CONTEXT;
1022 av_delete((AV*) saggregate, mg->mg_len, G_DISCARD);
1023 } else {
1024 char *key = mg->mg_ptr;
39b6627f 1025 I32 len = mg->mg_len;
7473853a 1026 assert ( mg->mg_ptr != 0 );
a1335164 1027 if (mg->mg_len == HEf_SVKEY) {
7600f30e
JH
1028 STRLEN slen;
1029 key = SvPV((SV *)mg->mg_ptr, slen);
1030 len = slen;
a1335164
JH
1031 if (SvUTF8((SV *)mg->mg_ptr)) {
1032 len = -len;
1033 }
1034 }
7473853a 1035 SHARED_CONTEXT;
c33e8be1 1036 (void) hv_delete((HV*) saggregate, key, len, G_DISCARD);
21312124 1037 }
6b85e4fe
NIS
1038 CALLER_CONTEXT;
1039 LEAVE_LOCK;
7473853a 1040 return (0);
21312124
NIS
1041}
1042
29ecdb6f
DM
1043/* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new
1044 * thread */
1045
0b057af7 1046static int
21312124
NIS
1047sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
1048{
c33e8be1 1049 PERL_UNUSED_ARG(param);
28399f57 1050 SvREFCNT_inc_void(SHAREDSV_FROM_OBJ(mg->mg_obj));
29ecdb6f 1051 assert(mg->mg_flags & MGf_DUP);
7473853a 1052 return (0);
21312124
NIS
1053}
1054
eeb9a2fc 1055const MGVTBL sharedsv_elem_vtbl = {
7473853a
SP
1056 sharedsv_elem_mg_FETCH, /* get */
1057 sharedsv_elem_mg_STORE, /* set */
1058 0, /* len */
1059 sharedsv_elem_mg_DELETE, /* clear */
1060 0, /* free */
1061 0, /* copy */
1062 sharedsv_elem_mg_dup, /* dup */
1063#ifdef MGf_LOCAL
1064 0, /* local */
1065#endif
21312124
NIS
1066};
1067
29ecdb6f
DM
1068/* ------------ PERL_MAGIC_tied(P) functions -------------- */
1069
7473853a 1070/* Len magic for PERL_MAGIC_tied(P) */
29ecdb6f 1071
0b057af7 1072static U32
21312124
NIS
1073sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
1074{
1075 dTHXc;
29ecdb6f 1076 SV *ssv = (SV *) mg->mg_ptr;
21312124 1077 U32 val;
c33e8be1 1078 PERL_UNUSED_ARG(sv);
21312124 1079 SHARED_EDIT;
29ecdb6f 1080 if (SvTYPE(ssv) == SVt_PVAV) {
7473853a
SP
1081 val = av_len((AV*) ssv);
1082 } else {
1083 /* Not actually defined by tie API but ... */
1b95d04f 1084 val = HvUSEDKEYS((HV*) ssv);
21312124
NIS
1085 }
1086 SHARED_RELEASE;
7473853a 1087 return (val);
21312124
NIS
1088}
1089
7473853a 1090/* Clear magic for PERL_MAGIC_tied(P) */
29ecdb6f 1091
0b057af7 1092static int
21312124
NIS
1093sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
1094{
1095 dTHXc;
29ecdb6f 1096 SV *ssv = (SV *) mg->mg_ptr;
6662c9a7 1097 const bool isav = SvTYPE(ssv) == SVt_PVAV;
c33e8be1 1098 PERL_UNUSED_ARG(sv);
21312124 1099 SHARED_EDIT;
6662c9a7
FC
1100 if (!PL_dirty) {
1101 SV **svp = isav ? AvARRAY((AV *)ssv) : NULL;
1102 I32 items = isav ? AvFILLp((AV *)ssv) + 1 : 0;
7d585d2f 1103 HE *iter;
6662c9a7
FC
1104 if (!isav) hv_iterinit((HV *)ssv);
1105 while (isav ? items-- : !!(iter = hv_iternext((HV *)ssv))) {
1106 SV *sv = isav ? *svp++ : HeVAL(iter);
7d585d2f
FC
1107 if (!sv) continue;
1108 if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv))))
1109 && SvREFCNT(sv) == 1 ) {
defb77b5 1110 SV *tmp;
7d585d2f 1111 PERL_SET_CONTEXT((aTHX = caller_perl));
defb77b5 1112 tmp = sv_newmortal();
7d585d2f
FC
1113 sv_upgrade(tmp, SVt_RV);
1114 get_RV(tmp, sv);
1115 PERL_SET_CONTEXT((aTHX = PL_sharedsv_space));
1116 }
1117 }
21312124 1118 }
6662c9a7
FC
1119 if (isav) av_clear((AV*) ssv);
1120 else hv_clear((HV*) ssv);
21312124 1121 SHARED_RELEASE;
7473853a 1122 return (0);
21312124
NIS
1123}
1124
7473853a 1125/* Free magic for PERL_MAGIC_tied(P) */
29ecdb6f 1126
0b057af7 1127static int
21312124
NIS
1128sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
1129{
c33e8be1 1130 PERL_UNUSED_ARG(sv);
29ecdb6f 1131 S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr);
7473853a 1132 return (0);
68795e93
NIS
1133}
1134
1135/*
7473853a 1136 * Copy magic for PERL_MAGIC_tied(P)
21312124
NIS
1137 * This is called when perl is about to access an element of
1138 * the array -
1139 */
33d16ee7 1140#if PERL_VERSION >= 11
0b057af7 1141static int
21312124 1142sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
3468c7ea 1143 SV *nsv, const char *name, I32 namlen)
33d16ee7 1144#else
0b057af7 1145static int
33d16ee7
JH
1146sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
1147 SV *nsv, const char *name, int namlen)
1148#endif
21312124 1149{
21312124 1150 MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
7473853a
SP
1151 toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
1152 name, namlen);
c33e8be1 1153 PERL_UNUSED_ARG(sv);
21312124 1154 nmg->mg_flags |= MGf_DUP;
7473853a 1155 return (1);
21312124
NIS
1156}
1157
29ecdb6f
DM
1158/* Called during cloning of PERL_MAGIC_tied(P) magic in new thread */
1159
0b057af7 1160static int
21312124
NIS
1161sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
1162{
c33e8be1 1163 PERL_UNUSED_ARG(param);
7473853a 1164 SvREFCNT_inc_void((SV*)mg->mg_ptr);
29ecdb6f 1165 assert(mg->mg_flags & MGf_DUP);
7473853a 1166 return (0);
21312124
NIS
1167}
1168
eeb9a2fc 1169const MGVTBL sharedsv_array_vtbl = {
7473853a
SP
1170 0, /* get */
1171 0, /* set */
1172 sharedsv_array_mg_FETCHSIZE,/* len */
1173 sharedsv_array_mg_CLEAR, /* clear */
1174 sharedsv_array_mg_free, /* free */
1175 sharedsv_array_mg_copy, /* copy */
1176 sharedsv_array_mg_dup, /* dup */
1177#ifdef MGf_LOCAL
1178 0, /* local */
1179#endif
21312124
NIS
1180};
1181
68795e93 1182
ba2940ce
JH
1183/* Recursive locks on a sharedsv.
1184 * Locks are dynamically scoped at the level of the first lock.
1185 */
0b057af7 1186static void
29ecdb6f 1187Perl_sharedsv_lock(pTHX_ SV *ssv)
68795e93 1188{
29ecdb6f 1189 user_lock *ul;
7473853a
SP
1190 if (! ssv)
1191 return;
29ecdb6f
DM
1192 ul = S_get_userlock(aTHX_ ssv, 1);
1193 recursive_lock_acquire(aTHX_ &ul->lock, __FILE__, __LINE__);
68795e93
NIS
1194}
1195
7473853a 1196/* Handles calls from lock() builtin via PL_lockhook */
afe38520 1197
0b057af7 1198static void
21312124
NIS
1199Perl_sharedsv_locksv(pTHX_ SV *sv)
1200{
29ecdb6f 1201 SV *ssv;
afe38520 1202
7473853a
SP
1203 if (SvROK(sv))
1204 sv = SvRV(sv);
29ecdb6f 1205 ssv = Perl_sharedsv_find(aTHX_ sv);
7473853a 1206 if (!ssv)
28399f57 1207 croak("lock can only be used on shared values");
29ecdb6f 1208 Perl_sharedsv_lock(aTHX_ ssv);
b050c948
AB
1209}
1210
b050c948 1211
794f4697
JH
1212/* Can a shared object be destroyed?
1213 * True if not a shared,
c4a6f826 1214 * or if destroying last proxy on a shared object
794f4697
JH
1215 */
1216#ifdef PL_destroyhook
0b057af7 1217static bool
794f4697
JH
1218Perl_shared_object_destroy(pTHX_ SV *sv)
1219{
1220 SV *ssv;
1221
1222 if (SvROK(sv))
1223 sv = SvRV(sv);
1224 ssv = Perl_sharedsv_find(aTHX_ sv);
1225 return (!ssv || (SvREFCNT(ssv) <= 1));
1226}
1227#endif
1228
c4a6f826 1229/* veto signal dispatch if we have the lock */
65c7421c
DM
1230
1231#ifdef PL_signalhook
1232
1233STATIC despatch_signals_proc_t prev_signal_hook = NULL;
1234
1235STATIC void
1236S_shared_signal_hook(pTHX) {
1237 int us;
1238 MUTEX_LOCK(&PL_sharedsv_lock.mutex);
1239 us = (PL_sharedsv_lock.owner == aTHX);
1240 MUTEX_UNLOCK(&PL_sharedsv_lock.mutex);
1241 if (us)
28399f57 1242 return; /* try again later */
16c91539 1243 prev_signal_hook(aTHX);
65c7421c
DM
1244}
1245#endif
794f4697 1246
ba2940ce 1247/* Saves a space for keeping SVs wider than an interpreter. */
21312124 1248
0b057af7 1249static void
21312124
NIS
1250Perl_sharedsv_init(pTHX)
1251{
7473853a 1252 dTHXc;
7473853a
SP
1253 PL_sharedsv_space = perl_alloc();
1254 perl_construct(PL_sharedsv_space);
78f43036
DM
1255 /* The pair above leaves us in shared context (what dTHX would get),
1256 * but aTHX still points to caller context */
1257 aTHX = PL_sharedsv_space;
0e7bfc0a
NC
1258 LEAVE; /* This balances the ENTER at the end of perl_construct. */
1259 PERL_SET_CONTEXT((aTHX = caller_perl));
7473853a
SP
1260 recursive_lock_init(aTHX_ &PL_sharedsv_lock);
1261 PL_lockhook = &Perl_sharedsv_locksv;
1262 PL_sharehook = &Perl_sharedsv_share;
794f4697
JH
1263#ifdef PL_destroyhook
1264 PL_destroyhook = &Perl_shared_object_destroy;
1265#endif
65c7421c
DM
1266#ifdef PL_signalhook
1267 if (!prev_signal_hook) {
28399f57
JH
1268 prev_signal_hook = PL_signalhook;
1269 PL_signalhook = &S_shared_signal_hook;
65c7421c
DM
1270 }
1271#endif
b050c948
AB
1272}
1273
73e09c8f
JH
1274#endif /* USE_ITHREADS */
1275
7473853a 1276MODULE = threads::shared PACKAGE = threads::shared::tie
b050c948 1277
21312124 1278PROTOTYPES: DISABLE
b050c948 1279
73e09c8f 1280#ifdef USE_ITHREADS
6b85e4fe 1281
21312124 1282void
29ecdb6f 1283PUSH(SV *obj, ...)
7473853a
SP
1284 CODE:
1285 dTHXc;
28399f57
JH
1286 SV *sobj = SHAREDSV_FROM_OBJ(obj);
1287 int ii;
1288 for (ii = 1; ii < items; ii++) {
1289 SV* tmp = newSVsv(ST(ii));
7473853a 1290 SV *stmp;
28399f57 1291 U32 dualvar_flags = DUALVAR_FLAGS(tmp);
7473853a
SP
1292 ENTER_LOCK;
1293 stmp = S_sharedsv_new_shared(aTHX_ tmp);
1294 sharedsv_scalar_store(aTHX_ tmp, stmp);
28399f57 1295 SvFLAGS(stmp) |= dualvar_flags;
7473853a
SP
1296 SHARED_CONTEXT;
1297 av_push((AV*) sobj, stmp);
1298 SvREFCNT_inc_void(stmp);
1299 SHARED_RELEASE;
1300 SvREFCNT_dec(tmp);
1301 }
1302
b050c948 1303
21312124 1304void
29ecdb6f 1305UNSHIFT(SV *obj, ...)
7473853a
SP
1306 CODE:
1307 dTHXc;
28399f57
JH
1308 SV *sobj = SHAREDSV_FROM_OBJ(obj);
1309 int ii;
7473853a
SP
1310 ENTER_LOCK;
1311 SHARED_CONTEXT;
1312 av_unshift((AV*)sobj, items - 1);
1313 CALLER_CONTEXT;
28399f57
JH
1314 for (ii = 1; ii < items; ii++) {
1315 SV *tmp = newSVsv(ST(ii));
1316 U32 dualvar_flags = DUALVAR_FLAGS(tmp);
7473853a
SP
1317 SV *stmp = S_sharedsv_new_shared(aTHX_ tmp);
1318 sharedsv_scalar_store(aTHX_ tmp, stmp);
1319 SHARED_CONTEXT;
28399f57
JH
1320 SvFLAGS(stmp) |= dualvar_flags;
1321 av_store((AV*) sobj, ii - 1, stmp);
7473853a
SP
1322 SvREFCNT_inc_void(stmp);
1323 CALLER_CONTEXT;
1324 SvREFCNT_dec(tmp);
1325 }
1326 LEAVE_LOCK;
1327
b050c948 1328
21312124 1329void
29ecdb6f 1330POP(SV *obj)
7473853a
SP
1331 CODE:
1332 dTHXc;
28399f57 1333 SV *sobj = SHAREDSV_FROM_OBJ(obj);
7473853a
SP
1334 SV* ssv;
1335 ENTER_LOCK;
1336 SHARED_CONTEXT;
1337 ssv = av_pop((AV*)sobj);
1338 CALLER_CONTEXT;
1339 ST(0) = sv_newmortal();
1340 Perl_sharedsv_associate(aTHX_ ST(0), ssv);
1341 SvREFCNT_dec(ssv);
1342 LEAVE_LOCK;
1343 /* XSRETURN(1); - implied */
1344
b050c948 1345
21312124 1346void
29ecdb6f 1347SHIFT(SV *obj)
7473853a
SP
1348 CODE:
1349 dTHXc;
28399f57 1350 SV *sobj = SHAREDSV_FROM_OBJ(obj);
7473853a
SP
1351 SV* ssv;
1352 ENTER_LOCK;
1353 SHARED_CONTEXT;
1354 ssv = av_shift((AV*)sobj);
1355 CALLER_CONTEXT;
1356 ST(0) = sv_newmortal();
1357 Perl_sharedsv_associate(aTHX_ ST(0), ssv);
1358 SvREFCNT_dec(ssv);
1359 LEAVE_LOCK;
1360 /* XSRETURN(1); - implied */
1361
b050c948 1362
21312124 1363void
29ecdb6f 1364EXTEND(SV *obj, IV count)
7473853a
SP
1365 CODE:
1366 dTHXc;
28399f57 1367 SV *sobj = SHAREDSV_FROM_OBJ(obj);
7473853a
SP
1368 SHARED_EDIT;
1369 av_extend((AV*)sobj, count);
1370 SHARED_RELEASE;
1371
b050c948 1372
21312124 1373void
29ecdb6f 1374STORESIZE(SV *obj,IV count)
7473853a
SP
1375 CODE:
1376 dTHXc;
76eea786
DM
1377 SV *ssv = SHAREDSV_FROM_OBJ(obj);
1378
7473853a 1379 SHARED_EDIT;
76eea786
DM
1380 assert(SvTYPE(ssv) == SVt_PVAV);
1381 if (!PL_dirty) {
1382 SV **svp = AvARRAY((AV *)ssv);
1383 I32 ix = AvFILLp((AV *)ssv);
1384 for (;ix >= count; ix--) {
1385 SV *sv = svp[ix];
1386 if (!sv)
1387 continue;
1388 if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv))))
1389 && SvREFCNT(sv) == 1 )
1390 {
defb77b5 1391 SV *tmp;
76eea786 1392 PERL_SET_CONTEXT((aTHX = caller_perl));
defb77b5 1393 tmp = sv_newmortal();
76eea786
DM
1394 sv_upgrade(tmp, SVt_RV);
1395 get_RV(tmp, sv);
1396 PERL_SET_CONTEXT((aTHX = PL_sharedsv_space));
1397 }
1398 }
1399 }
1400 av_fill((AV*) ssv, count - 1);
7473853a 1401 SHARED_RELEASE;
6b85e4fe
NIS
1402
1403
1404void
29ecdb6f 1405EXISTS(SV *obj, SV *index)
7473853a
SP
1406 CODE:
1407 dTHXc;
28399f57 1408 SV *sobj = SHAREDSV_FROM_OBJ(obj);
7473853a
SP
1409 bool exists;
1410 if (SvTYPE(sobj) == SVt_PVAV) {
1411 SHARED_EDIT;
1412 exists = av_exists((AV*) sobj, SvIV(index));
1413 } else {
39b6627f 1414 I32 len;
7600f30e
JH
1415 STRLEN slen;
1416 char *key = SvPVutf8(index, slen);
1417 len = slen;
a1335164
JH
1418 if (SvUTF8(index)) {
1419 len = -len;
1420 }
7473853a
SP
1421 SHARED_EDIT;
1422 exists = hv_exists((HV*) sobj, key, len);
1423 }
1424 SHARED_RELEASE;
1425 ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
1426 /* XSRETURN(1); - implied */
b050c948
AB
1427
1428
1429void
29ecdb6f 1430FIRSTKEY(SV *obj)
7473853a
SP
1431 CODE:
1432 dTHXc;
28399f57 1433 SV *sobj = SHAREDSV_FROM_OBJ(obj);
7473853a
SP
1434 char* key = NULL;
1435 I32 len = 0;
1436 HE* entry;
1437 ENTER_LOCK;
1438 SHARED_CONTEXT;
1439 hv_iterinit((HV*) sobj);
1440 entry = hv_iternext((HV*) sobj);
1441 if (entry) {
a1335164 1442 I32 utf8 = HeKUTF8(entry);
7473853a
SP
1443 key = hv_iterkey(entry,&len);
1444 CALLER_CONTEXT;
8a8fad9a 1445 ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0));
7473853a
SP
1446 } else {
1447 CALLER_CONTEXT;
1448 ST(0) = &PL_sv_undef;
1449 }
1450 LEAVE_LOCK;
1451 /* XSRETURN(1); - implied */
1452
b050c948 1453
866fba46 1454void
29ecdb6f 1455NEXTKEY(SV *obj, SV *oldkey)
7473853a
SP
1456 CODE:
1457 dTHXc;
28399f57 1458 SV *sobj = SHAREDSV_FROM_OBJ(obj);
7473853a
SP
1459 char* key = NULL;
1460 I32 len = 0;
1461 HE* entry;
2a6601ce
RGS
1462
1463 PERL_UNUSED_VAR(oldkey);
1464
7473853a
SP
1465 ENTER_LOCK;
1466 SHARED_CONTEXT;
1467 entry = hv_iternext((HV*) sobj);
1468 if (entry) {
a1335164 1469 I32 utf8 = HeKUTF8(entry);
7473853a
SP
1470 key = hv_iterkey(entry,&len);
1471 CALLER_CONTEXT;
8a8fad9a 1472 ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0));
7473853a
SP
1473 } else {
1474 CALLER_CONTEXT;
1475 ST(0) = &PL_sv_undef;
1476 }
1477 LEAVE_LOCK;
1478 /* XSRETURN(1); - implied */
1479
1480
1481MODULE = threads::shared PACKAGE = threads::shared
21312124
NIS
1482
1483PROTOTYPES: ENABLE
866fba46 1484
68795e93 1485void
39ec4146 1486_id(SV *myref)
7473853a
SP
1487 PROTOTYPE: \[$@%]
1488 PREINIT:
1489 SV *ssv;
1490 CODE:
39ec4146 1491 myref = SvRV(myref);
373098c0
JH
1492 if (SvMAGICAL(myref))
1493 mg_get(myref);
39ec4146
RGS
1494 if (SvROK(myref))
1495 myref = SvRV(myref);
1496 ssv = Perl_sharedsv_find(aTHX_ myref);
7473853a
SP
1497 if (! ssv)
1498 XSRETURN_UNDEF;
1499 ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv)));
1500 /* XSRETURN(1); - implied */
9c4972d9
NIS
1501
1502
1503void
39ec4146 1504_refcnt(SV *myref)
7473853a
SP
1505 PROTOTYPE: \[$@%]
1506 PREINIT:
1507 SV *ssv;
1508 CODE:
39ec4146
RGS
1509 myref = SvRV(myref);
1510 if (SvROK(myref))
1511 myref = SvRV(myref);
1512 ssv = Perl_sharedsv_find(aTHX_ myref);
7473853a 1513 if (! ssv) {
7c8caac0
JH
1514 if (ckWARN(WARN_THREADS)) {
1515 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1516 "%" SVf " is not shared", ST(0));
1517 }
7473853a
SP
1518 XSRETURN_UNDEF;
1519 }
1520 ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv)));
1521 /* XSRETURN(1); - implied */
1522
1523
1524void
39ec4146 1525share(SV *myref)
7473853a
SP
1526 PROTOTYPE: \[$@%]
1527 CODE:
39ec4146 1528 if (! SvROK(myref))
56fcff86 1529 Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
39ec4146
RGS
1530 myref = SvRV(myref);
1531 if (SvROK(myref))
1532 myref = SvRV(myref);
1533 Perl_sharedsv_share(aTHX_ myref);
1534 ST(0) = sv_2mortal(newRV_inc(myref));
7473853a 1535 /* XSRETURN(1); - implied */
a446a88f 1536
6f942b98
AB
1537
1538void
7473853a
SP
1539cond_wait(SV *ref_cond, SV *ref_lock = 0)
1540 PROTOTYPE: \[$@%];\[$@%]
1541 PREINIT:
1542 SV *ssv;
1543 perl_cond* user_condition;
1544 int locks;
1545 user_lock *ul;
1546 CODE:
1547 if (!SvROK(ref_cond))
56fcff86 1548 Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
7473853a
SP
1549 ref_cond = SvRV(ref_cond);
1550 if (SvROK(ref_cond))
1551 ref_cond = SvRV(ref_cond);
1552 ssv = Perl_sharedsv_find(aTHX_ ref_cond);
1553 if (! ssv)
1554 Perl_croak(aTHX_ "cond_wait can only be used on shared values");
1555 ul = S_get_userlock(aTHX_ ssv, 1);
1556
1557 user_condition = &ul->user_cond;
1558 if (ref_lock && (ref_cond != ref_lock)) {
1559 if (!SvROK(ref_lock))
1560 Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref");
1561 ref_lock = SvRV(ref_lock);
1562 if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1563 ssv = Perl_sharedsv_find(aTHX_ ref_lock);
1564 if (! ssv)
1565 Perl_croak(aTHX_ "cond_wait lock must be a shared value");
1566 ul = S_get_userlock(aTHX_ ssv, 1);
1567 }
1568 if (ul->lock.owner != aTHX)
1569 croak("You need a lock before you can cond_wait");
ba2940ce 1570
7473853a
SP
1571 /* Stealing the members of the lock object worries me - NI-S */
1572 MUTEX_LOCK(&ul->lock.mutex);
1573 ul->lock.owner = NULL;
1574 locks = ul->lock.locks;
1575 ul->lock.locks = 0;
1576
ba2940ce
JH
1577 /* Since we are releasing the lock here, we need to tell other
1578 * people that it is ok to go ahead and use it */
7473853a
SP
1579 COND_SIGNAL(&ul->lock.cond);
1580 COND_WAIT(user_condition, &ul->lock.mutex);
ba2940ce 1581 while (ul->lock.owner != NULL) {
7473853a
SP
1582 /* OK -- must reacquire the lock */
1583 COND_WAIT(&ul->lock.cond, &ul->lock.mutex);
1584 }
1585 ul->lock.owner = aTHX;
1586 ul->lock.locks = locks;
1587 MUTEX_UNLOCK(&ul->lock.mutex);
1588
a0e036c1
MP
1589
1590int
7473853a
SP
1591cond_timedwait(SV *ref_cond, double abs, SV *ref_lock = 0)
1592 PROTOTYPE: \[$@%]$;\[$@%]
1593 PREINIT:
1594 SV *ssv;
1595 perl_cond* user_condition;
1596 int locks;
1597 user_lock *ul;
1598 CODE:
1599 if (! SvROK(ref_cond))
1600 Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref");
1601 ref_cond = SvRV(ref_cond);
1602 if (SvROK(ref_cond))
1603 ref_cond = SvRV(ref_cond);
1604 ssv = Perl_sharedsv_find(aTHX_ ref_cond);
1605 if (! ssv)
1606 Perl_croak(aTHX_ "cond_timedwait can only be used on shared values");
1607 ul = S_get_userlock(aTHX_ ssv, 1);
1608
1609 user_condition = &ul->user_cond;
1610 if (ref_lock && (ref_cond != ref_lock)) {
1611 if (! SvROK(ref_lock))
1612 Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref");
1613 ref_lock = SvRV(ref_lock);
1614 if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1615 ssv = Perl_sharedsv_find(aTHX_ ref_lock);
1616 if (! ssv)
1617 Perl_croak(aTHX_ "cond_timedwait lock must be a shared value");
1618 ul = S_get_userlock(aTHX_ ssv, 1);
1619 }
1620 if (ul->lock.owner != aTHX)
1621 Perl_croak(aTHX_ "You need a lock before you can cond_wait");
1622
1623 MUTEX_LOCK(&ul->lock.mutex);
1624 ul->lock.owner = NULL;
1625 locks = ul->lock.locks;
1626 ul->lock.locks = 0;
ba2940ce
JH
1627 /* Since we are releasing the lock here, we need to tell other
1628 * people that it is ok to go ahead and use it */
7473853a
SP
1629 COND_SIGNAL(&ul->lock.cond);
1630 RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs);
1631 while (ul->lock.owner != NULL) {
1632 /* OK -- must reacquire the lock... */
1633 COND_WAIT(&ul->lock.cond, &ul->lock.mutex);
1634 }
1635 ul->lock.owner = aTHX;
1636 ul->lock.locks = locks;
1637 MUTEX_UNLOCK(&ul->lock.mutex);
1638
1639 if (RETVAL == 0)
a0e036c1 1640 XSRETURN_UNDEF;
7473853a
SP
1641 OUTPUT:
1642 RETVAL
a0e036c1 1643
29ecdb6f 1644
7473853a 1645void
39ec4146 1646cond_signal(SV *myref)
7473853a
SP
1647 PROTOTYPE: \[$@%]
1648 PREINIT:
1649 SV *ssv;
1650 user_lock *ul;
1651 CODE:
39ec4146 1652 if (! SvROK(myref))
56fcff86 1653 Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
39ec4146
RGS
1654 myref = SvRV(myref);
1655 if (SvROK(myref))
1656 myref = SvRV(myref);
1657 ssv = Perl_sharedsv_find(aTHX_ myref);
7473853a
SP
1658 if (! ssv)
1659 Perl_croak(aTHX_ "cond_signal can only be used on shared values");
1660 ul = S_get_userlock(aTHX_ ssv, 1);
1661 if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) {
1662 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1663 "cond_signal() called on unlocked variable");
1664 }
1665 COND_SIGNAL(&ul->user_cond);
6f942b98 1666
29ecdb6f 1667
7473853a 1668void
39ec4146 1669cond_broadcast(SV *myref)
7473853a
SP
1670 PROTOTYPE: \[$@%]
1671 PREINIT:
1672 SV *ssv;
1673 user_lock *ul;
1674 CODE:
39ec4146 1675 if (! SvROK(myref))
56fcff86 1676 Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
39ec4146
RGS
1677 myref = SvRV(myref);
1678 if (SvROK(myref))
1679 myref = SvRV(myref);
1680 ssv = Perl_sharedsv_find(aTHX_ myref);
7473853a
SP
1681 if (! ssv)
1682 Perl_croak(aTHX_ "cond_broadcast can only be used on shared values");
1683 ul = S_get_userlock(aTHX_ ssv, 1);
1684 if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) {
1685 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1686 "cond_broadcast() called on unlocked variable");
1687 }
1688 COND_BROADCAST(&ul->user_cond);
1689
1690
1691void
28399f57 1692bless(SV* myref, ...)
7473853a
SP
1693 PROTOTYPE: $;$
1694 PREINIT:
1695 HV* stash;
1696 SV *ssv;
1697 CODE:
1698 if (items == 1) {
1699 stash = CopSTASH(PL_curcop);
1700 } else {
1701 SV* classname = ST(1);
1702 STRLEN len;
1703 char *ptr;
1704
1705 if (classname &&
1706 ! SvGMAGICAL(classname) &&
1707 ! SvAMAGIC(classname) &&
1708 SvROK(classname))
1709 {
1710 Perl_croak(aTHX_ "Attempt to bless into a reference");
1711 }
1712 ptr = SvPV(classname, len);
1713 if (ckWARN(WARN_MISC) && len == 0) {
1714 Perl_warner(aTHX_ packWARN(WARN_MISC),
1715 "Explicit blessing to '' (assuming package main)");
1716 }
1717 stash = gv_stashpvn(ptr, len, TRUE);
1718 }
39ec4146
RGS
1719 SvREFCNT_inc_void(myref);
1720 (void)sv_bless(myref, stash);
1721 ST(0) = sv_2mortal(myref);
1722 ssv = Perl_sharedsv_find(aTHX_ myref);
7473853a
SP
1723 if (ssv) {
1724 dTHXc;
1725 ENTER_LOCK;
1726 SHARED_CONTEXT;
1727 {
1728 SV* fake_stash = newSVpv(HvNAME_get(stash), 0);
1729 (void)sv_bless(ssv, (HV*)fake_stash);
1730 }
1731 CALLER_CONTEXT;
1732 LEAVE_LOCK;
1733 }
1734 /* XSRETURN(1); - implied */
5c360ac5 1735
73e09c8f
JH
1736#endif /* USE_ITHREADS */
1737
68795e93
NIS
1738BOOT:
1739{
73e09c8f 1740#ifdef USE_ITHREADS
68795e93 1741 Perl_sharedsv_init(aTHX);
73e09c8f 1742#endif /* USE_ITHREADS */
68795e93 1743}