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