This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH] Update Pod::Perldoc from 3.10 to 3.11
[perl5.git] / ext / threads / shared / shared.xs
CommitLineData
afe38520 1/* shared.xs
68795e93 2 *
afe38520 3 * Copyright (c) 2001-2002, Larry Wall
68795e93
NIS
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
21312124
NIS
8 * "Hand any two wizards a piece of rope and they would instinctively pull in
9 * opposite directions."
10 * --Sourcery
11 *
12 * Contributed by Arthur Bergman arthur@contiller.se
13 * pulled in the (an)other direction by Nick Ing-Simmons nick@ing-simmons.net
14 */
68795e93
NIS
15
16#define PERL_NO_GET_CONTEXT
b050c948
AB
17#include "EXTERN.h"
18#include "perl.h"
19#include "XSUB.h"
20
73e09c8f
JH
21#ifdef USE_ITHREADS
22
21312124
NIS
23#define SHAREDSvPTR(a) ((a)->sv)
24
25/*
26 * The shared things need an intepreter to live in ...
27 */
28PerlInterpreter *PL_sharedsv_space; /* The shared sv space */
29/* To access shared space we fake aTHX in this scope and thread's context */
30#define SHARED_CONTEXT PERL_SET_CONTEXT((aTHX = PL_sharedsv_space))
31
32/* So we need a way to switch back to the caller's context... */
33/* So we declare _another_ copy of the aTHX variable ... */
34#define dTHXc PerlInterpreter *caller_perl = aTHX
35/* and use it to switch back */
36#define CALLER_CONTEXT PERL_SET_CONTEXT((aTHX = caller_perl))
37
38/*
39 * Only one thread at a time is allowed to mess with shared space.
40 */
a446a88f 41
6d56dc1c
NIS
42typedef struct
43{
44 perl_mutex mutex;
6d56dc1c
NIS
45 PerlInterpreter *owner;
46 I32 locks;
6b85e4fe
NIS
47 perl_cond cond;
48#ifdef DEBUG_LOCKS
49 char * file;
50 int line;
51#endif
6d56dc1c
NIS
52} recursive_lock_t;
53
54recursive_lock_t PL_sharedsv_lock; /* Mutex protecting the shared sv space */
55
56void
57recursive_lock_init(pTHX_ recursive_lock_t *lock)
58{
59 Zero(lock,1,recursive_lock_t);
60 MUTEX_INIT(&lock->mutex);
61 COND_INIT(&lock->cond);
62}
63
a39edb3a 64void
579f9913
AB
65recursive_lock_destroy(pTHX_ recursive_lock_t *lock)
66{
67 MUTEX_DESTROY(&lock->mutex);
68 COND_DESTROY(&lock->cond);
69}
70
6d56dc1c
NIS
71void
72recursive_lock_release(pTHX_ recursive_lock_t *lock)
73{
74 MUTEX_LOCK(&lock->mutex);
75 if (lock->owner != aTHX) {
76 MUTEX_UNLOCK(&lock->mutex);
77 }
78 else {
79 if (--lock->locks == 0) {
80 lock->owner = NULL;
81 COND_SIGNAL(&lock->cond);
82 }
83 }
84 MUTEX_UNLOCK(&lock->mutex);
85}
a446a88f 86
6d56dc1c 87void
6b85e4fe 88recursive_lock_acquire(pTHX_ recursive_lock_t *lock,char *file,int line)
6d56dc1c
NIS
89{
90 assert(aTHX);
91 MUTEX_LOCK(&lock->mutex);
92 if (lock->owner == aTHX) {
93 lock->locks++;
94 }
95 else {
6b85e4fe
NIS
96 while (lock->owner) {
97#ifdef DEBUG_LOCKS
98 Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n",
99 aTHX, lock->owner, lock->file, lock->line);
100#endif
6d56dc1c 101 COND_WAIT(&lock->cond,&lock->mutex);
6b85e4fe 102 }
6d56dc1c
NIS
103 lock->locks = 1;
104 lock->owner = aTHX;
6b85e4fe
NIS
105#ifdef DEBUG_LOCKS
106 lock->file = file;
107 lock->line = line;
108#endif
6d56dc1c
NIS
109 }
110 MUTEX_UNLOCK(&lock->mutex);
6b85e4fe 111 SAVEDESTRUCTOR_X(recursive_lock_release,lock);
6d56dc1c
NIS
112}
113
114#define ENTER_LOCK STMT_START { \
115 ENTER; \
6b85e4fe 116 recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__); \
a446a88f 117 } STMT_END
21312124 118
6d56dc1c
NIS
119#define LEAVE_LOCK LEAVE
120
21312124
NIS
121
122/* A common idiom is to acquire access and switch in ... */
123#define SHARED_EDIT STMT_START { \
6d56dc1c 124 ENTER_LOCK; \
21312124
NIS
125 SHARED_CONTEXT; \
126 } STMT_END
127
128/* then switch out and release access. */
129#define SHARED_RELEASE STMT_START { \
130 CALLER_CONTEXT; \
6d56dc1c 131 LEAVE_LOCK; \
21312124 132 } STMT_END
85e0a142 133
21312124
NIS
134
135/*
136
137 Shared SV
138
139 Shared SV is a structure for keeping the backend storage
140 of shared svs.
141
142 Shared-ness really only needs the SV * - the rest is for locks.
143 (Which suggests further space optimization ... )
144
145*/
68795e93
NIS
146
147typedef struct {
21312124 148 SV *sv; /* The actual SV - in shared space */
6d56dc1c 149 recursive_lock_t lock;
68795e93 150 perl_cond user_cond; /* For user-level conditions */
68795e93
NIS
151} shared_sv;
152
21312124
NIS
153/* The SV in shared-space has a back-pointer to the shared_sv
154 struct associated with it PERL_MAGIC_ext.
68795e93 155
21312124
NIS
156 The vtable used has just one entry - when the SV goes away
157 we free the memory for the above.
68795e93 158
21312124 159 */
68795e93 160
21312124
NIS
161int
162sharedsv_shared_mg_free(pTHX_ SV *sv, MAGIC *mg)
163{
164 shared_sv *shared = (shared_sv *) mg->mg_ptr;
6b85e4fe 165 assert( aTHX == PL_sharedsv_space );
21312124 166 if (shared) {
cab6ddb1 167 recursive_lock_destroy(aTHX_ &shared->lock);
579f9913 168 COND_DESTROY(&shared->user_cond);
21312124
NIS
169 PerlMemShared_free(shared);
170 mg->mg_ptr = NULL;
171 }
172 return 0;
173}
174
21312124
NIS
175MGVTBL sharedsv_shared_vtbl = {
176 0, /* get */
177 0, /* set */
178 0, /* len */
179 0, /* clear */
180 sharedsv_shared_mg_free, /* free */
181 0, /* copy */
182 0, /* dup */
183};
184
185/* Access to shared things is heavily based on MAGIC - in mg.h/mg.c/sv.c sense */
186
187/* In any thread that has access to a shared thing there is a "proxy"
188 for it in its own space which has 'MAGIC' associated which accesses
189 the shared thing.
190 */
191
192MGVTBL sharedsv_scalar_vtbl; /* scalars have this vtable */
193MGVTBL sharedsv_array_vtbl; /* hashes and arrays have this - like 'tie' */
194MGVTBL sharedsv_elem_vtbl; /* elements of hashes and arrays have this
195 _AS WELL AS_ the scalar magic */
196
197/* The sharedsv_elem_vtbl associates the element with the array/hash and
198 the sharedsv_scalar_vtbl associates it with the value
199 */
200
6b85e4fe
NIS
201
202/* Accessor to convert threads::shared::tie objects back shared_sv * */
203shared_sv *
204SV_to_sharedsv(pTHX_ SV *sv)
205{
206 shared_sv *shared = 0;
207 if (SvROK(sv))
208 {
209 shared = INT2PTR(shared_sv *, SvIV(SvRV(sv)));
210 }
211 return shared;
212}
213
21312124
NIS
214=for apidoc sharedsv_find
215
6b85e4fe 216Given a private side SV tries to find if the SV has a shared backend,
21312124
NIS
217by looking for the magic.
218
219=cut
220
221shared_sv *
222Perl_sharedsv_find(pTHX_ SV *sv)
223{
224 MAGIC *mg;
a446a88f
NIS
225 if (SvTYPE(sv) >= SVt_PVMG) {
226 switch(SvTYPE(sv)) {
227 case SVt_PVAV:
228 case SVt_PVHV:
229 if ((mg = mg_find(sv, PERL_MAGIC_tied))
230 && mg->mg_virtual == &sharedsv_array_vtbl) {
21312124
NIS
231 return (shared_sv *) mg->mg_ptr;
232 }
233 break;
a446a88f 234 default:
6b85e4fe
NIS
235 /* This should work for elements as well as they
236 * have scalar magic as well as their element magic
237 */
a446a88f
NIS
238 if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar))
239 && mg->mg_virtual == &sharedsv_scalar_vtbl) {
21312124 240 return (shared_sv *) mg->mg_ptr;
6b85e4fe 241 }
a446a88f 242 break;
21312124
NIS
243 }
244 }
6b85e4fe
NIS
245 /* Just for tidyness of API also handle tie objects */
246 if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) {
247 return SV_to_sharedsv(aTHX_ sv);
248 }
21312124
NIS
249 return NULL;
250}
68795e93
NIS
251
252/*
21312124
NIS
253 * Almost all the pain is in this routine.
254 *
255 */
68795e93 256
21312124
NIS
257shared_sv *
258Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data)
259{
21312124 260 dTHXc;
a446a88f 261 MAGIC *mg = 0;
6b85e4fe 262 SV *sv = (psv) ? *psv : Nullsv;
a446a88f
NIS
263
264 /* If we are asked for an private ops we need a thread */
265 assert ( aTHX != PL_sharedsv_space );
266
267 /* To avoid need for recursive locks require caller to hold lock */
6d56dc1c 268 assert ( PL_sharedsv_lock.owner == aTHX );
6b85e4fe
NIS
269
270 /* First try and get existing global data structure */
68795e93 271
21312124 272 /* Try shared SV as 1st choice */
a446a88f 273 if (!data && ssv && SvTYPE(ssv) >= SVt_PVMG) {
436c6dd3 274 if( (mg = mg_find(ssv, PERL_MAGIC_ext)) ){
21312124
NIS
275 data = (shared_sv *) mg->mg_ptr;
276 }
277 }
6b85e4fe
NIS
278
279 /* Next see if private SV is associated with something */
280 if (!data && sv) {
281 data = Perl_sharedsv_find(aTHX_ sv);
21312124 282 }
6b85e4fe 283
21312124
NIS
284 /* If neither of those then create a new one */
285 if (!data) {
6b85e4fe 286 SHARED_CONTEXT;
b0cd0593 287 if (!ssv) {
6b85e4fe 288 ssv = newSV(0);
b0cd0593
AB
289 SvREFCNT(ssv) = 0;
290 }
21312124
NIS
291 data = PerlMemShared_malloc(sizeof(shared_sv));
292 Zero(data,1,shared_sv);
6b85e4fe
NIS
293 SHAREDSvPTR(data) = ssv;
294 /* Tag shared side SV with data pointer */
295 sv_magicext(ssv, ssv, PERL_MAGIC_ext, &sharedsv_shared_vtbl,
296 (char *)data, 0);
6d56dc1c 297 recursive_lock_init(aTHX_ &data->lock);
21312124 298 COND_INIT(&data->user_cond);
6b85e4fe 299 CALLER_CONTEXT;
21312124 300 }
68795e93 301
21312124
NIS
302 if (!ssv)
303 ssv = SHAREDSvPTR(data);
6b85e4fe
NIS
304 if (!SHAREDSvPTR(data))
305 SHAREDSvPTR(data) = ssv;
306
307 /* If we know type upgrade shared side SV */
308 if (sv && SvTYPE(ssv) < SvTYPE(sv)) {
21312124 309 SHARED_CONTEXT;
21312124 310 sv_upgrade(ssv, SvTYPE(*psv));
21312124
NIS
311 CALLER_CONTEXT;
312 }
68795e93 313
21312124 314 /* Now if requested allocate private SV */
6b85e4fe
NIS
315 if (psv && !sv) {
316 *psv = sv = newSV(0);
21312124
NIS
317 }
318
319 /* Finally if private SV exists check and add magic */
6b85e4fe 320 if (sv) {
a446a88f 321 MAGIC *mg = 0;
6b85e4fe
NIS
322 if (SvTYPE(sv) < SvTYPE(ssv)) {
323 sv_upgrade(sv, SvTYPE(ssv));
324 }
21312124
NIS
325 switch(SvTYPE(sv)) {
326 case SVt_PVAV:
327 case SVt_PVHV:
328 if (!(mg = mg_find(sv, PERL_MAGIC_tied))
6b85e4fe
NIS
329 || mg->mg_virtual != &sharedsv_array_vtbl
330 || (shared_sv *) mg->mg_ptr != data) {
a446a88f
NIS
331 SV *obj = newSV(0);
332 sv_setref_iv(obj, "threads::shared::tie",PTR2IV(data));
6b85e4fe 333 if (mg) {
21312124 334 sv_unmagic(sv, PERL_MAGIC_tied);
6b85e4fe 335 }
a446a88f 336 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
21312124
NIS
337 (char *) data, 0);
338 mg->mg_flags |= (MGf_COPY|MGf_DUP);
6b85e4fe 339 SvREFCNT_inc(ssv);
a446a88f 340 SvREFCNT_dec(obj);
5c360ac5
AB
341 if(SvOBJECT(ssv)) {
342 STRLEN len;
343 char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len);
344 HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
345 SvOBJECT_on(sv);
346 SvSTASH(sv) = (HV*)SvREFCNT_inc(stash);
347 }
21312124
NIS
348 }
349 break;
350
351 default:
6b85e4fe
NIS
352 if ((SvTYPE(sv) < SVt_PVMG)
353 || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar))
354 || mg->mg_virtual != &sharedsv_scalar_vtbl
355 || (shared_sv *) mg->mg_ptr != data) {
356 if (mg) {
21312124 357 sv_unmagic(sv, PERL_MAGIC_shared_scalar);
6b85e4fe 358 }
21312124
NIS
359 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
360 &sharedsv_scalar_vtbl, (char *)data, 0);
361 mg->mg_flags |= (MGf_COPY|MGf_DUP);
6b85e4fe 362 SvREFCNT_inc(ssv);
21312124
NIS
363 }
364 break;
365 }
6d56dc1c 366 assert ( Perl_sharedsv_find(aTHX_ *psv) == data );
21312124 367 }
21312124
NIS
368 return data;
369}
68795e93
NIS
370
371void
21312124 372Perl_sharedsv_free(pTHX_ shared_sv *shared)
68795e93 373{
21312124
NIS
374 if (shared) {
375 dTHXc;
376 SHARED_EDIT;
377 SvREFCNT_dec(SHAREDSvPTR(shared));
378 SHARED_RELEASE;
379 }
68795e93
NIS
380}
381
21312124
NIS
382void
383Perl_sharedsv_share(pTHX_ SV *sv)
384{
385 switch(SvTYPE(sv)) {
386 case SVt_PVGV:
387 Perl_croak(aTHX_ "Cannot share globs yet");
388 break;
389
390 case SVt_PVCV:
391 Perl_croak(aTHX_ "Cannot share subs yet");
392 break;
85e0a142 393
21312124 394 default:
6d56dc1c 395 ENTER_LOCK;
21312124 396 Perl_sharedsv_associate(aTHX_ &sv, 0, 0);
6d56dc1c 397 LEAVE_LOCK;
a446a88f
NIS
398 SvSETMAGIC(sv);
399 break;
21312124
NIS
400 }
401}
68795e93 402
21312124 403/* MAGIC (in mg.h sense) hooks */
68795e93 404
21312124
NIS
405int
406sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
68795e93 407{
21312124 408 shared_sv *shared = (shared_sv *) mg->mg_ptr;
6b85e4fe 409 assert(shared);
21312124 410
6d56dc1c 411 ENTER_LOCK;
21312124
NIS
412 if (SHAREDSvPTR(shared)) {
413 if (SvROK(SHAREDSvPTR(shared))) {
a446a88f
NIS
414 SV *obj = Nullsv;
415 Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
416 sv_setsv_nomg(sv, &PL_sv_undef);
417 SvRV(sv) = obj;
418 SvROK_on(sv);
5c360ac5 419
21312124
NIS
420 }
421 else {
a446a88f 422 sv_setsv_nomg(sv, SHAREDSvPTR(shared));
21312124
NIS
423 }
424 }
6d56dc1c 425 LEAVE_LOCK;
21312124
NIS
426 return 0;
427}
428
6b85e4fe
NIS
429void
430sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared)
21312124
NIS
431{
432 dTHXc;
21312124 433 bool allowed = TRUE;
21312124
NIS
434 if (SvROK(sv)) {
435 shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
436 if (target) {
a446a88f
NIS
437 SV *tmp;
438 SHARED_CONTEXT;
439 tmp = newRV(SHAREDSvPTR(target));
440 sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
21312124 441 SvREFCNT_dec(tmp);
5c360ac5
AB
442 if(SvOBJECT(SvRV(sv))) {
443 SV* fake_stash = newSVpv(HvNAME(SvSTASH(SvRV(sv))),0);
444 SvOBJECT_on(SHAREDSvPTR(target));
445 SvSTASH(SHAREDSvPTR(target)) = (HV*)fake_stash;
446 }
a446a88f 447 CALLER_CONTEXT;
21312124
NIS
448 }
449 else {
450 allowed = FALSE;
451 }
452 }
453 else {
5c360ac5 454 SvTEMP_off(sv);
a446a88f
NIS
455 SHARED_CONTEXT;
456 sv_setsv_nomg(SHAREDSvPTR(shared), sv);
5c360ac5
AB
457 if(SvOBJECT(sv)) {
458 SV* fake_stash = newSVpv(HvNAME(SvSTASH(sv)),0);
459 SvOBJECT_on(SHAREDSvPTR(shared));
460 SvSTASH(SHAREDSvPTR(shared)) = (HV*)fake_stash;
461 }
a446a88f 462 CALLER_CONTEXT;
21312124 463 }
21312124
NIS
464 if (!allowed) {
465 Perl_croak(aTHX_ "Invalid value for shared scalar");
466 }
6b85e4fe
NIS
467}
468
469int
470sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
471{
472 shared_sv *shared;
473 ENTER_LOCK;
474 /* We call associate to potentially upgrade shared side SV */
475 shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr);
476 assert(shared);
477 sharedsv_scalar_store(aTHX_ sv, shared);
478 LEAVE_LOCK;
21312124 479 return 0;
68795e93
NIS
480}
481
21312124
NIS
482int
483sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
484{
a446a88f 485 shared_sv *shared = (shared_sv *) mg->mg_ptr;
eb31b78e 486#if 0
a446a88f 487 assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
eb31b78e 488#endif
a446a88f
NIS
489 Perl_sharedsv_free(aTHX_ shared);
490 return 0;
491}
492
493int
494sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
495{
21312124
NIS
496 return 0;
497}
68795e93
NIS
498
499/*
21312124
NIS
500 * Called during cloning of new threads
501 */
502int
503sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
504{
505 shared_sv *shared = (shared_sv *) mg->mg_ptr;
506 if (shared) {
507 SvREFCNT_inc(SHAREDSvPTR(shared));
508 }
509 return 0;
510}
68795e93 511
21312124
NIS
512MGVTBL sharedsv_scalar_vtbl = {
513 sharedsv_scalar_mg_get, /* get */
514 sharedsv_scalar_mg_set, /* set */
515 0, /* len */
a446a88f 516 sharedsv_scalar_mg_clear, /* clear */
21312124
NIS
517 sharedsv_scalar_mg_free, /* free */
518 0, /* copy */
519 sharedsv_scalar_mg_dup /* dup */
520};
68795e93 521
21312124 522/* Now the arrays/hashes stuff */
21312124
NIS
523int
524sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
68795e93 525{
21312124 526 dTHXc;
6b85e4fe 527 shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
21312124
NIS
528 shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
529 SV** svp;
530
a446a88f
NIS
531 assert ( shared );
532 assert ( SHAREDSvPTR(shared) );
533
6b85e4fe 534 ENTER_LOCK;
21312124 535 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
a446a88f 536 assert ( mg->mg_ptr == 0 );
6b85e4fe 537 SHARED_CONTEXT;
a446a88f 538 svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
21312124
NIS
539 }
540 else {
6b85e4fe
NIS
541 char *key = mg->mg_ptr;
542 STRLEN len = mg->mg_len;
a446a88f 543 assert ( mg->mg_ptr != 0 );
6b85e4fe
NIS
544 if (mg->mg_len == HEf_SVKEY) {
545 key = SvPV((SV *) mg->mg_ptr, len);
546 }
547 SHARED_CONTEXT;
548 svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0);
21312124 549 }
6b85e4fe 550 CALLER_CONTEXT;
21312124 551 if (svp) {
6b85e4fe
NIS
552 /* Exists in the array */
553 target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
554 sv_setsv(sv, *svp);
21312124 555 }
6b85e4fe
NIS
556 else {
557 /* Not in the array */
558 sv_setsv(sv, &PL_sv_undef);
68795e93 559 }
6b85e4fe 560 LEAVE_LOCK;
21312124 561 return 0;
68795e93
NIS
562}
563
21312124
NIS
564int
565sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
566{
567 dTHXc;
6b85e4fe 568 shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
a446a88f 569 shared_sv *target;
6b85e4fe 570 SV **svp;
21312124
NIS
571 /* Theory - SV itself is magically shared - and we have ordered the
572 magic such that by the time we get here it has been stored
573 to its shared counterpart
574 */
6d56dc1c
NIS
575 ENTER_LOCK;
576 assert(shared);
577 assert(SHAREDSvPTR(shared));
21312124 578 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
6b85e4fe
NIS
579 assert ( mg->mg_ptr == 0 );
580 SHARED_CONTEXT;
581 svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 1);
21312124
NIS
582 }
583 else {
6b85e4fe
NIS
584 char *key = mg->mg_ptr;
585 STRLEN len = mg->mg_len;
586 assert ( mg->mg_ptr != 0 );
587 if (mg->mg_len == HEf_SVKEY)
588 key = SvPV((SV *) mg->mg_ptr, len);
589 SHARED_CONTEXT;
590 svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 1);
21312124 591 }
6b85e4fe
NIS
592 CALLER_CONTEXT;
593 target = Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
594 sharedsv_scalar_store(aTHX_ sv, target);
595 LEAVE_LOCK;
21312124
NIS
596 return 0;
597}
68795e93 598
21312124
NIS
599int
600sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
68795e93 601{
21312124 602 dTHXc;
6b85e4fe 603 shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
6b85e4fe
NIS
604 ENTER_LOCK;
605 sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
21312124 606 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
6b85e4fe
NIS
607 SHARED_CONTEXT;
608 av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
68795e93 609 }
21312124 610 else {
6b85e4fe
NIS
611 char *key = mg->mg_ptr;
612 STRLEN len = mg->mg_len;
613 assert ( mg->mg_ptr != 0 );
614 if (mg->mg_len == HEf_SVKEY)
615 key = SvPV((SV *) mg->mg_ptr, len);
616 SHARED_CONTEXT;
617 hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD);
21312124 618 }
6b85e4fe
NIS
619 CALLER_CONTEXT;
620 LEAVE_LOCK;
21312124
NIS
621 return 0;
622}
623
21312124
NIS
624int
625sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
626{
6b85e4fe 627 Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj));
21312124
NIS
628 return 0;
629}
630
631int
632sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
633{
6b85e4fe 634 shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
21312124
NIS
635 SvREFCNT_inc(SHAREDSvPTR(shared));
636 mg->mg_flags |= MGf_DUP;
637 return 0;
638}
639
640MGVTBL sharedsv_elem_vtbl = {
641 sharedsv_elem_mg_FETCH, /* get */
642 sharedsv_elem_mg_STORE, /* set */
643 0, /* len */
644 sharedsv_elem_mg_DELETE, /* clear */
645 sharedsv_elem_mg_free, /* free */
646 0, /* copy */
647 sharedsv_elem_mg_dup /* dup */
648};
649
650U32
651sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
652{
653 dTHXc;
654 shared_sv *shared = (shared_sv *) mg->mg_ptr;
655 U32 val;
656 SHARED_EDIT;
657 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
658 val = av_len((AV*) SHAREDSvPTR(shared));
659 }
660 else {
661 /* not actually defined by tie API but ... */
662 val = HvKEYS((HV*) SHAREDSvPTR(shared));
663 }
664 SHARED_RELEASE;
665 return val;
666}
667
668int
669sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
670{
671 dTHXc;
672 shared_sv *shared = (shared_sv *) mg->mg_ptr;
673 SHARED_EDIT;
674 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
675 av_clear((AV*) SHAREDSvPTR(shared));
676 }
677 else {
678 hv_clear((HV*) SHAREDSvPTR(shared));
679 }
680 SHARED_RELEASE;
681 return 0;
682}
683
684int
685sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
686{
687 Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
688 return 0;
68795e93
NIS
689}
690
691/*
21312124
NIS
692 * This is called when perl is about to access an element of
693 * the array -
694 */
695int
696sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
697 SV *nsv, const char *name, int namlen)
698{
699 shared_sv *shared = (shared_sv *) mg->mg_ptr;
700 MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
701 toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
702 name, namlen);
b747d46a 703 ENTER_LOCK;
a446a88f 704 SvREFCNT_inc(SHAREDSvPTR(shared));
b747d46a 705 LEAVE_LOCK;
21312124 706 nmg->mg_flags |= MGf_DUP;
21312124
NIS
707 return 1;
708}
709
710int
711sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
712{
713 shared_sv *shared = (shared_sv *) mg->mg_ptr;
714 SvREFCNT_inc(SHAREDSvPTR(shared));
715 mg->mg_flags |= MGf_DUP;
716 return 0;
717}
718
719MGVTBL sharedsv_array_vtbl = {
720 0, /* get */
721 0, /* set */
722 sharedsv_array_mg_FETCHSIZE, /* len */
723 sharedsv_array_mg_CLEAR, /* clear */
724 sharedsv_array_mg_free, /* free */
725 sharedsv_array_mg_copy, /* copy */
726 sharedsv_array_mg_dup /* dup */
727};
728
729=for apidoc sharedsv_unlock
68795e93
NIS
730
731Recursively unlocks a shared sv.
732
21312124 733=cut
68795e93
NIS
734
735void
736Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
737{
6d56dc1c 738 recursive_lock_release(aTHX_ &ssv->lock);
68795e93
NIS
739}
740
21312124 741=for apidoc sharedsv_lock
68795e93 742
21312124
NIS
743Recursive locks on a sharedsv.
744Locks are dynamically scoped at the level of the first lock.
68795e93 745
21312124 746=cut
68795e93
NIS
747
748void
21312124 749Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
68795e93 750{
21312124
NIS
751 if (!ssv)
752 return;
6b85e4fe 753 recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
68795e93
NIS
754}
755
afe38520
DM
756/* handles calls from lock() builtin via PL_lockhook */
757
21312124
NIS
758void
759Perl_sharedsv_locksv(pTHX_ SV *sv)
760{
afe38520
DM
761 shared_sv* shared;
762
763 if(SvROK(sv))
764 sv = SvRV(sv);
38875929 765 shared = Perl_sharedsv_find(aTHX_ sv);
afe38520
DM
766 if(!shared)
767 croak("lock can only be used on shared values");
768 Perl_sharedsv_lock(aTHX_ shared);
b050c948
AB
769}
770
21312124 771=head1 Shared SV Functions
b050c948 772
21312124 773=for apidoc sharedsv_init
b050c948 774
21312124 775Saves a space for keeping SVs wider than an interpreter,
b050c948 776
21312124
NIS
777=cut
778
779void
780Perl_sharedsv_init(pTHX)
781{
782 dTHXc;
783 /* This pair leaves us in shared context ... */
784 PL_sharedsv_space = perl_alloc();
785 perl_construct(PL_sharedsv_space);
786 CALLER_CONTEXT;
6d56dc1c 787 recursive_lock_init(aTHX_ &PL_sharedsv_lock);
21312124
NIS
788 PL_lockhook = &Perl_sharedsv_locksv;
789 PL_sharehook = &Perl_sharedsv_share;
b050c948
AB
790}
791
73e09c8f
JH
792#endif /* USE_ITHREADS */
793
21312124 794MODULE = threads::shared PACKAGE = threads::shared::tie
b050c948 795
21312124 796PROTOTYPES: DISABLE
b050c948 797
73e09c8f 798#ifdef USE_ITHREADS
6b85e4fe 799
21312124
NIS
800void
801PUSH(shared_sv *shared, ...)
802CODE:
803 dTHXc;
804 int i;
21312124
NIS
805 for(i = 1; i < items; i++) {
806 SV* tmp = newSVsv(ST(i));
a446a88f 807 shared_sv *target;
6d56dc1c 808 ENTER_LOCK;
a446a88f 809 target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
6b85e4fe 810 sharedsv_scalar_store(aTHX_ tmp, target);
21312124
NIS
811 SHARED_CONTEXT;
812 av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
b0cd0593 813 SvREFCNT_inc(SHAREDSvPTR(target));
a446a88f 814 SHARED_RELEASE;
21312124
NIS
815 SvREFCNT_dec(tmp);
816 }
b050c948 817
21312124
NIS
818void
819UNSHIFT(shared_sv *shared, ...)
820CODE:
821 dTHXc;
822 int i;
6d56dc1c 823 ENTER_LOCK;
21312124
NIS
824 SHARED_CONTEXT;
825 av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
826 CALLER_CONTEXT;
827 for(i = 1; i < items; i++) {
828 SV* tmp = newSVsv(ST(i));
829 shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
6b85e4fe 830 sharedsv_scalar_store(aTHX_ tmp, target);
21312124
NIS
831 SHARED_CONTEXT;
832 av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
b0cd0593 833 SvREFCNT_inc(SHAREDSvPTR(target));
21312124
NIS
834 CALLER_CONTEXT;
835 SvREFCNT_dec(tmp);
836 }
6d56dc1c 837 LEAVE_LOCK;
b050c948 838
21312124
NIS
839void
840POP(shared_sv *shared)
841CODE:
842 dTHXc;
843 SV* sv;
6d56dc1c 844 ENTER_LOCK;
21312124
NIS
845 SHARED_CONTEXT;
846 sv = av_pop((AV*)SHAREDSvPTR(shared));
847 CALLER_CONTEXT;
9b018978 848 ST(0) = sv_newmortal();
21312124 849 Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
9b018978 850 SvREFCNT_dec(sv);
6d56dc1c 851 LEAVE_LOCK;
21312124 852 XSRETURN(1);
b050c948 853
21312124
NIS
854void
855SHIFT(shared_sv *shared)
856CODE:
857 dTHXc;
858 SV* sv;
6d56dc1c 859 ENTER_LOCK;
21312124
NIS
860 SHARED_CONTEXT;
861 sv = av_shift((AV*)SHAREDSvPTR(shared));
862 CALLER_CONTEXT;
9b018978 863 ST(0) = sv_newmortal();
21312124 864 Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
9b018978 865 SvREFCNT_dec(sv);
6d56dc1c 866 LEAVE_LOCK;
21312124 867 XSRETURN(1);
b050c948 868
21312124
NIS
869void
870EXTEND(shared_sv *shared, IV count)
871CODE:
872 dTHXc;
873 SHARED_EDIT;
874 av_extend((AV*)SHAREDSvPTR(shared), count);
875 SHARED_RELEASE;
b050c948 876
21312124 877void
6b85e4fe
NIS
878STORESIZE(shared_sv *shared,IV count)
879CODE:
880 dTHXc;
881 SHARED_EDIT;
882 av_fill((AV*) SHAREDSvPTR(shared), count);
883 SHARED_RELEASE;
884
885
886
887
888void
21312124
NIS
889EXISTS(shared_sv *shared, SV *index)
890CODE:
891 dTHXc;
892 bool exists;
893 SHARED_EDIT;
894 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
895 exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
896 }
897 else {
6b85e4fe
NIS
898 STRLEN len;
899 char *key = SvPV(index,len);
900 exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
21312124
NIS
901 }
902 SHARED_RELEASE;
903 ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
904 XSRETURN(1);
b050c948
AB
905
906
907void
21312124
NIS
908FIRSTKEY(shared_sv *shared)
909CODE:
910 dTHXc;
911 char* key = NULL;
912 I32 len = 0;
913 HE* entry;
6d56dc1c 914 ENTER_LOCK;
21312124
NIS
915 SHARED_CONTEXT;
916 hv_iterinit((HV*) SHAREDSvPTR(shared));
917 entry = hv_iternext((HV*) SHAREDSvPTR(shared));
918 if (entry) {
919 key = hv_iterkey(entry,&len);
920 CALLER_CONTEXT;
921 ST(0) = sv_2mortal(newSVpv(key, len));
922 } else {
923 CALLER_CONTEXT;
924 ST(0) = &PL_sv_undef;
925 }
6d56dc1c 926 LEAVE_LOCK;
21312124 927 XSRETURN(1);
b050c948 928
866fba46 929void
21312124
NIS
930NEXTKEY(shared_sv *shared, SV *oldkey)
931CODE:
932 dTHXc;
933 char* key = NULL;
934 I32 len = 0;
935 HE* entry;
6d56dc1c 936 ENTER_LOCK;
21312124
NIS
937 SHARED_CONTEXT;
938 entry = hv_iternext((HV*) SHAREDSvPTR(shared));
6b85e4fe 939 if (entry) {
21312124
NIS
940 key = hv_iterkey(entry,&len);
941 CALLER_CONTEXT;
942 ST(0) = sv_2mortal(newSVpv(key, len));
943 } else {
944 CALLER_CONTEXT;
945 ST(0) = &PL_sv_undef;
946 }
6d56dc1c 947 LEAVE_LOCK;
21312124
NIS
948 XSRETURN(1);
949
950MODULE = threads::shared PACKAGE = threads::shared
951
952PROTOTYPES: ENABLE
866fba46 953
68795e93 954void
9c4972d9
NIS
955_id(SV *ref)
956 PROTOTYPE: \[$@%]
957CODE:
958 shared_sv *shared;
afe38520 959 ref = SvRV(ref);
9c4972d9
NIS
960 if(SvROK(ref))
961 ref = SvRV(ref);
436c6dd3 962 if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
9c4972d9
NIS
963 ST(0) = sv_2mortal(newSViv(PTR2IV(shared)));
964 XSRETURN(1);
965 }
966 XSRETURN_UNDEF;
967
968
969void
6b85e4fe 970_refcnt(SV *ref)
a446a88f
NIS
971 PROTOTYPE: \[$@%]
972CODE:
973 shared_sv *shared;
afe38520 974 ref = SvRV(ref);
a446a88f
NIS
975 if(SvROK(ref))
976 ref = SvRV(ref);
436c6dd3 977 if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
a446a88f
NIS
978 if (SHAREDSvPTR(shared)) {
979 ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
980 XSRETURN(1);
981 }
982 else {
436c6dd3 983 Perl_warn(aTHX_ "%" SVf " s=%p has no shared SV",ST(0),shared);
a446a88f
NIS
984 }
985 }
986 else {
436c6dd3 987 Perl_warn(aTHX_ "%" SVf " is not shared",ST(0));
a446a88f
NIS
988 }
989 XSRETURN_UNDEF;
990
caf25f3b 991SV*
a446a88f
NIS
992share(SV *ref)
993 PROTOTYPE: \[$@%]
994 CODE:
56fcff86
AB
995 if(!SvROK(ref))
996 Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
afe38520 997 ref = SvRV(ref);
a446a88f
NIS
998 if(SvROK(ref))
999 ref = SvRV(ref);
38875929 1000 Perl_sharedsv_share(aTHX_ ref);
caf25f3b
AB
1001 RETVAL = newRV(ref);
1002 OUTPUT:
1003 RETVAL
a446a88f
NIS
1004
1005void
21312124 1006lock_enabled(SV *ref)
ce127893 1007 PROTOTYPE: \[$@%]
6f942b98
AB
1008 CODE:
1009 shared_sv* shared;
56fcff86
AB
1010 if(!SvROK(ref))
1011 Perl_croak(aTHX_ "Argument to lock needs to be passed as ref");
afe38520 1012 ref = SvRV(ref);
6f942b98
AB
1013 if(SvROK(ref))
1014 ref = SvRV(ref);
38875929 1015 shared = Perl_sharedsv_find(aTHX_ ref);
21312124
NIS
1016 if(!shared)
1017 croak("lock can only be used on shared values");
1018 Perl_sharedsv_lock(aTHX_ shared);
6f942b98
AB
1019
1020void
21312124 1021cond_wait_enabled(SV *ref)
ce127893 1022 PROTOTYPE: \[$@%]
6f942b98
AB
1023 CODE:
1024 shared_sv* shared;
1025 int locks;
56fcff86
AB
1026 if(!SvROK(ref))
1027 Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
afe38520 1028 ref = SvRV(ref);
6f942b98
AB
1029 if(SvROK(ref))
1030 ref = SvRV(ref);
1031 shared = Perl_sharedsv_find(aTHX_ ref);
1032 if(!shared)
1033 croak("cond_wait can only be used on shared values");
6d56dc1c 1034 if(shared->lock.owner != aTHX)
6f942b98 1035 croak("You need a lock before you can cond_wait");
6d56dc1c
NIS
1036 /* Stealing the members of the lock object worries me - NI-S */
1037 MUTEX_LOCK(&shared->lock.mutex);
1038 shared->lock.owner = NULL;
39f33d92
AB
1039 locks = shared->lock.locks;
1040 shared->lock.locks = 0;
89661126
AB
1041
1042 /* since we are releasing the lock here we need to tell other
1043 people that is ok to go ahead and use it */
1044 COND_SIGNAL(&shared->lock.cond);
6d56dc1c 1045 COND_WAIT(&shared->user_cond, &shared->lock.mutex);
89661126
AB
1046 while(shared->lock.owner != NULL) {
1047 COND_WAIT(&shared->lock.cond,&shared->lock.mutex);
1048 }
6d56dc1c
NIS
1049 shared->lock.owner = aTHX;
1050 shared->lock.locks = locks;
1051 MUTEX_UNLOCK(&shared->lock.mutex);
6f942b98 1052
21312124
NIS
1053void
1054cond_signal_enabled(SV *ref)
ce127893 1055 PROTOTYPE: \[$@%]
6f942b98
AB
1056 CODE:
1057 shared_sv* shared;
56fcff86
AB
1058 if(!SvROK(ref))
1059 Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
afe38520 1060 ref = SvRV(ref);
6f942b98
AB
1061 if(SvROK(ref))
1062 ref = SvRV(ref);
1063 shared = Perl_sharedsv_find(aTHX_ ref);
38875929
DM
1064 if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1065 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1066 "cond_signal() called on unlocked variable");
6f942b98
AB
1067 if(!shared)
1068 croak("cond_signal can only be used on shared values");
1069 COND_SIGNAL(&shared->user_cond);
1070
21312124
NIS
1071void
1072cond_broadcast_enabled(SV *ref)
ce127893 1073 PROTOTYPE: \[$@%]
6f942b98
AB
1074 CODE:
1075 shared_sv* shared;
56fcff86
AB
1076 if(!SvROK(ref))
1077 Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
afe38520 1078 ref = SvRV(ref);
6f942b98
AB
1079 if(SvROK(ref))
1080 ref = SvRV(ref);
1081 shared = Perl_sharedsv_find(aTHX_ ref);
1082 if(!shared)
1083 croak("cond_broadcast can only be used on shared values");
38875929
DM
1084 if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1085 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1086 "cond_broadcast() called on unlocked variable");
6f942b98 1087 COND_BROADCAST(&shared->user_cond);
b050c948 1088
5c360ac5
AB
1089
1090SV*
1091bless(SV* ref, ...);
1092 PROTOTYPE: $;$
1093 CODE:
1094 {
1095 HV* stash;
1096 shared_sv* shared;
1097 if (items == 1)
1098 stash = CopSTASH(PL_curcop);
1099 else {
1100 SV* ssv = ST(1);
1101 STRLEN len;
1102 char *ptr;
1103
1104 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
1105 Perl_croak(aTHX_ "Attempt to bless into a reference");
1106 ptr = SvPV(ssv,len);
1107 if (ckWARN(WARN_MISC) && len == 0)
1108 Perl_warner(aTHX_ packWARN(WARN_MISC),
1109 "Explicit blessing to '' (assuming package main)");
1110 stash = gv_stashpvn(ptr, len, TRUE);
1111 }
1112 SvREFCNT_inc(ref);
1113 (void)sv_bless(ref, stash);
1114 RETVAL = ref;
1115 shared = Perl_sharedsv_find(aTHX_ ref);
1116 if(shared) {
1117 dTHXc;
1118 ENTER_LOCK;
1119 SHARED_CONTEXT;
1120 {
1121 SV* fake_stash = newSVpv(HvNAME(stash),0);
1122 (void)sv_bless(SHAREDSvPTR(shared),(HV*)fake_stash);
1123 }
1124 CALLER_CONTEXT;
1125 LEAVE_LOCK;
1126 }
1127 }
1128 OUTPUT:
1129 RETVAL
1130
73e09c8f
JH
1131#endif /* USE_ITHREADS */
1132
68795e93
NIS
1133BOOT:
1134{
73e09c8f 1135#ifdef USE_ITHREADS
68795e93 1136 Perl_sharedsv_init(aTHX);
73e09c8f 1137#endif /* USE_ITHREADS */
68795e93 1138}
73e09c8f
JH
1139
1140
1141