This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate:
[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));
aa49c2f8
DM
311 if (SvTYPE(ssv) == SVt_PVAV) /* #24061 */
312 AvREAL_on(ssv);
21312124
NIS
313 CALLER_CONTEXT;
314 }
68795e93 315
21312124 316 /* Now if requested allocate private SV */
6b85e4fe
NIS
317 if (psv && !sv) {
318 *psv = sv = newSV(0);
21312124
NIS
319 }
320
321 /* Finally if private SV exists check and add magic */
6b85e4fe 322 if (sv) {
a446a88f 323 MAGIC *mg = 0;
6b85e4fe
NIS
324 if (SvTYPE(sv) < SvTYPE(ssv)) {
325 sv_upgrade(sv, SvTYPE(ssv));
326 }
21312124
NIS
327 switch(SvTYPE(sv)) {
328 case SVt_PVAV:
329 case SVt_PVHV:
330 if (!(mg = mg_find(sv, PERL_MAGIC_tied))
6b85e4fe
NIS
331 || mg->mg_virtual != &sharedsv_array_vtbl
332 || (shared_sv *) mg->mg_ptr != data) {
a446a88f
NIS
333 SV *obj = newSV(0);
334 sv_setref_iv(obj, "threads::shared::tie",PTR2IV(data));
6b85e4fe 335 if (mg) {
21312124 336 sv_unmagic(sv, PERL_MAGIC_tied);
6b85e4fe 337 }
a446a88f 338 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
21312124
NIS
339 (char *) data, 0);
340 mg->mg_flags |= (MGf_COPY|MGf_DUP);
6b85e4fe 341 SvREFCNT_inc(ssv);
a446a88f 342 SvREFCNT_dec(obj);
5c360ac5
AB
343 if(SvOBJECT(ssv)) {
344 STRLEN len;
345 char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len);
346 HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
347 SvOBJECT_on(sv);
348 SvSTASH(sv) = (HV*)SvREFCNT_inc(stash);
349 }
21312124
NIS
350 }
351 break;
352
353 default:
6b85e4fe
NIS
354 if ((SvTYPE(sv) < SVt_PVMG)
355 || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar))
356 || mg->mg_virtual != &sharedsv_scalar_vtbl
357 || (shared_sv *) mg->mg_ptr != data) {
358 if (mg) {
21312124 359 sv_unmagic(sv, PERL_MAGIC_shared_scalar);
6b85e4fe 360 }
21312124
NIS
361 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
362 &sharedsv_scalar_vtbl, (char *)data, 0);
363 mg->mg_flags |= (MGf_COPY|MGf_DUP);
6b85e4fe 364 SvREFCNT_inc(ssv);
21312124
NIS
365 }
366 break;
367 }
6d56dc1c 368 assert ( Perl_sharedsv_find(aTHX_ *psv) == data );
21312124 369 }
21312124
NIS
370 return data;
371}
68795e93
NIS
372
373void
21312124 374Perl_sharedsv_free(pTHX_ shared_sv *shared)
68795e93 375{
21312124
NIS
376 if (shared) {
377 dTHXc;
378 SHARED_EDIT;
379 SvREFCNT_dec(SHAREDSvPTR(shared));
380 SHARED_RELEASE;
381 }
68795e93
NIS
382}
383
21312124
NIS
384void
385Perl_sharedsv_share(pTHX_ SV *sv)
386{
387 switch(SvTYPE(sv)) {
388 case SVt_PVGV:
389 Perl_croak(aTHX_ "Cannot share globs yet");
390 break;
391
392 case SVt_PVCV:
393 Perl_croak(aTHX_ "Cannot share subs yet");
394 break;
85e0a142 395
21312124 396 default:
6d56dc1c 397 ENTER_LOCK;
21312124 398 Perl_sharedsv_associate(aTHX_ &sv, 0, 0);
6d56dc1c 399 LEAVE_LOCK;
a446a88f
NIS
400 SvSETMAGIC(sv);
401 break;
21312124
NIS
402 }
403}
68795e93 404
21312124 405/* MAGIC (in mg.h sense) hooks */
68795e93 406
21312124
NIS
407int
408sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
68795e93 409{
21312124 410 shared_sv *shared = (shared_sv *) mg->mg_ptr;
6b85e4fe 411 assert(shared);
21312124 412
6d56dc1c 413 ENTER_LOCK;
21312124
NIS
414 if (SHAREDSvPTR(shared)) {
415 if (SvROK(SHAREDSvPTR(shared))) {
a446a88f
NIS
416 SV *obj = Nullsv;
417 Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
418 sv_setsv_nomg(sv, &PL_sv_undef);
419 SvRV(sv) = obj;
420 SvROK_on(sv);
5c360ac5 421
21312124
NIS
422 }
423 else {
a446a88f 424 sv_setsv_nomg(sv, SHAREDSvPTR(shared));
21312124
NIS
425 }
426 }
6d56dc1c 427 LEAVE_LOCK;
21312124
NIS
428 return 0;
429}
430
6b85e4fe
NIS
431void
432sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared)
21312124
NIS
433{
434 dTHXc;
21312124 435 bool allowed = TRUE;
21312124
NIS
436 if (SvROK(sv)) {
437 shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
438 if (target) {
a446a88f
NIS
439 SV *tmp;
440 SHARED_CONTEXT;
aa49c2f8
DM
441 /* #24255: sv_setsv() (via sv_unref_flags()) may cause a
442 * deferred free with sv_2mortal(). Ensure that the free_tmps
1624910a 443 * is done within this interpreter. DAPM.
aa49c2f8
DM
444 */
445 ENTER;
446 SAVETMPS;
a446a88f
NIS
447 tmp = newRV(SHAREDSvPTR(target));
448 sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
21312124 449 SvREFCNT_dec(tmp);
5c360ac5
AB
450 if(SvOBJECT(SvRV(sv))) {
451 SV* fake_stash = newSVpv(HvNAME(SvSTASH(SvRV(sv))),0);
452 SvOBJECT_on(SHAREDSvPTR(target));
453 SvSTASH(SHAREDSvPTR(target)) = (HV*)fake_stash;
454 }
aa49c2f8
DM
455 FREETMPS;
456 LEAVE;
a446a88f 457 CALLER_CONTEXT;
21312124
NIS
458 }
459 else {
460 allowed = FALSE;
461 }
462 }
463 else {
5c360ac5 464 SvTEMP_off(sv);
a446a88f
NIS
465 SHARED_CONTEXT;
466 sv_setsv_nomg(SHAREDSvPTR(shared), sv);
5c360ac5
AB
467 if(SvOBJECT(sv)) {
468 SV* fake_stash = newSVpv(HvNAME(SvSTASH(sv)),0);
469 SvOBJECT_on(SHAREDSvPTR(shared));
470 SvSTASH(SHAREDSvPTR(shared)) = (HV*)fake_stash;
471 }
a446a88f 472 CALLER_CONTEXT;
21312124 473 }
21312124
NIS
474 if (!allowed) {
475 Perl_croak(aTHX_ "Invalid value for shared scalar");
476 }
6b85e4fe
NIS
477}
478
479int
480sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
481{
482 shared_sv *shared;
483 ENTER_LOCK;
484 /* We call associate to potentially upgrade shared side SV */
485 shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr);
486 assert(shared);
487 sharedsv_scalar_store(aTHX_ sv, shared);
488 LEAVE_LOCK;
21312124 489 return 0;
68795e93
NIS
490}
491
21312124
NIS
492int
493sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
494{
a446a88f 495 shared_sv *shared = (shared_sv *) mg->mg_ptr;
eb31b78e 496#if 0
a446a88f 497 assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
eb31b78e 498#endif
a446a88f
NIS
499 Perl_sharedsv_free(aTHX_ shared);
500 return 0;
501}
502
503int
504sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
505{
21312124
NIS
506 return 0;
507}
68795e93
NIS
508
509/*
21312124
NIS
510 * Called during cloning of new threads
511 */
512int
513sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
514{
515 shared_sv *shared = (shared_sv *) mg->mg_ptr;
516 if (shared) {
517 SvREFCNT_inc(SHAREDSvPTR(shared));
518 }
519 return 0;
520}
68795e93 521
21312124
NIS
522MGVTBL sharedsv_scalar_vtbl = {
523 sharedsv_scalar_mg_get, /* get */
524 sharedsv_scalar_mg_set, /* set */
525 0, /* len */
a446a88f 526 sharedsv_scalar_mg_clear, /* clear */
21312124
NIS
527 sharedsv_scalar_mg_free, /* free */
528 0, /* copy */
529 sharedsv_scalar_mg_dup /* dup */
530};
68795e93 531
21312124 532/* Now the arrays/hashes stuff */
21312124
NIS
533int
534sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
68795e93 535{
21312124 536 dTHXc;
6b85e4fe 537 shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
21312124
NIS
538 shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
539 SV** svp;
540
a446a88f
NIS
541 assert ( shared );
542 assert ( SHAREDSvPTR(shared) );
543
6b85e4fe 544 ENTER_LOCK;
21312124 545 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
a446a88f 546 assert ( mg->mg_ptr == 0 );
6b85e4fe 547 SHARED_CONTEXT;
a446a88f 548 svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
21312124
NIS
549 }
550 else {
6b85e4fe
NIS
551 char *key = mg->mg_ptr;
552 STRLEN len = mg->mg_len;
a446a88f 553 assert ( mg->mg_ptr != 0 );
6b85e4fe
NIS
554 if (mg->mg_len == HEf_SVKEY) {
555 key = SvPV((SV *) mg->mg_ptr, len);
556 }
557 SHARED_CONTEXT;
558 svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0);
21312124 559 }
6b85e4fe 560 CALLER_CONTEXT;
21312124 561 if (svp) {
6b85e4fe
NIS
562 /* Exists in the array */
563 target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
564 sv_setsv(sv, *svp);
21312124 565 }
6b85e4fe
NIS
566 else {
567 /* Not in the array */
568 sv_setsv(sv, &PL_sv_undef);
68795e93 569 }
6b85e4fe 570 LEAVE_LOCK;
21312124 571 return 0;
68795e93
NIS
572}
573
21312124
NIS
574int
575sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
576{
577 dTHXc;
6b85e4fe 578 shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
a446a88f 579 shared_sv *target;
6b85e4fe 580 SV **svp;
21312124
NIS
581 /* Theory - SV itself is magically shared - and we have ordered the
582 magic such that by the time we get here it has been stored
583 to its shared counterpart
584 */
6d56dc1c
NIS
585 ENTER_LOCK;
586 assert(shared);
587 assert(SHAREDSvPTR(shared));
21312124 588 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
6b85e4fe
NIS
589 assert ( mg->mg_ptr == 0 );
590 SHARED_CONTEXT;
591 svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 1);
21312124
NIS
592 }
593 else {
6b85e4fe
NIS
594 char *key = mg->mg_ptr;
595 STRLEN len = mg->mg_len;
596 assert ( mg->mg_ptr != 0 );
597 if (mg->mg_len == HEf_SVKEY)
598 key = SvPV((SV *) mg->mg_ptr, len);
599 SHARED_CONTEXT;
600 svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 1);
21312124 601 }
6b85e4fe
NIS
602 CALLER_CONTEXT;
603 target = Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
604 sharedsv_scalar_store(aTHX_ sv, target);
605 LEAVE_LOCK;
21312124
NIS
606 return 0;
607}
68795e93 608
21312124
NIS
609int
610sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
68795e93 611{
21312124 612 dTHXc;
6b85e4fe 613 shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
6b85e4fe
NIS
614 ENTER_LOCK;
615 sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
21312124 616 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
6b85e4fe
NIS
617 SHARED_CONTEXT;
618 av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
68795e93 619 }
21312124 620 else {
6b85e4fe
NIS
621 char *key = mg->mg_ptr;
622 STRLEN len = mg->mg_len;
623 assert ( mg->mg_ptr != 0 );
624 if (mg->mg_len == HEf_SVKEY)
625 key = SvPV((SV *) mg->mg_ptr, len);
626 SHARED_CONTEXT;
627 hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD);
21312124 628 }
6b85e4fe
NIS
629 CALLER_CONTEXT;
630 LEAVE_LOCK;
21312124
NIS
631 return 0;
632}
633
21312124
NIS
634int
635sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
636{
6b85e4fe 637 Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj));
21312124
NIS
638 return 0;
639}
640
641int
642sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
643{
6b85e4fe 644 shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
21312124
NIS
645 SvREFCNT_inc(SHAREDSvPTR(shared));
646 mg->mg_flags |= MGf_DUP;
647 return 0;
648}
649
650MGVTBL sharedsv_elem_vtbl = {
651 sharedsv_elem_mg_FETCH, /* get */
652 sharedsv_elem_mg_STORE, /* set */
653 0, /* len */
654 sharedsv_elem_mg_DELETE, /* clear */
655 sharedsv_elem_mg_free, /* free */
656 0, /* copy */
657 sharedsv_elem_mg_dup /* dup */
658};
659
660U32
661sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
662{
663 dTHXc;
664 shared_sv *shared = (shared_sv *) mg->mg_ptr;
665 U32 val;
666 SHARED_EDIT;
667 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
668 val = av_len((AV*) SHAREDSvPTR(shared));
669 }
670 else {
671 /* not actually defined by tie API but ... */
672 val = HvKEYS((HV*) SHAREDSvPTR(shared));
673 }
674 SHARED_RELEASE;
675 return val;
676}
677
678int
679sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
680{
681 dTHXc;
682 shared_sv *shared = (shared_sv *) mg->mg_ptr;
683 SHARED_EDIT;
684 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
685 av_clear((AV*) SHAREDSvPTR(shared));
686 }
687 else {
688 hv_clear((HV*) SHAREDSvPTR(shared));
689 }
690 SHARED_RELEASE;
691 return 0;
692}
693
694int
695sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
696{
697 Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
698 return 0;
68795e93
NIS
699}
700
701/*
21312124
NIS
702 * This is called when perl is about to access an element of
703 * the array -
704 */
705int
706sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
707 SV *nsv, const char *name, int namlen)
708{
709 shared_sv *shared = (shared_sv *) mg->mg_ptr;
710 MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
711 toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
712 name, namlen);
b747d46a 713 ENTER_LOCK;
a446a88f 714 SvREFCNT_inc(SHAREDSvPTR(shared));
b747d46a 715 LEAVE_LOCK;
21312124 716 nmg->mg_flags |= MGf_DUP;
21312124
NIS
717 return 1;
718}
719
720int
721sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
722{
723 shared_sv *shared = (shared_sv *) mg->mg_ptr;
724 SvREFCNT_inc(SHAREDSvPTR(shared));
725 mg->mg_flags |= MGf_DUP;
726 return 0;
727}
728
729MGVTBL sharedsv_array_vtbl = {
730 0, /* get */
731 0, /* set */
732 sharedsv_array_mg_FETCHSIZE, /* len */
733 sharedsv_array_mg_CLEAR, /* clear */
734 sharedsv_array_mg_free, /* free */
735 sharedsv_array_mg_copy, /* copy */
736 sharedsv_array_mg_dup /* dup */
737};
738
739=for apidoc sharedsv_unlock
68795e93
NIS
740
741Recursively unlocks a shared sv.
742
21312124 743=cut
68795e93
NIS
744
745void
746Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
747{
6d56dc1c 748 recursive_lock_release(aTHX_ &ssv->lock);
68795e93
NIS
749}
750
21312124 751=for apidoc sharedsv_lock
68795e93 752
21312124
NIS
753Recursive locks on a sharedsv.
754Locks are dynamically scoped at the level of the first lock.
68795e93 755
21312124 756=cut
68795e93
NIS
757
758void
21312124 759Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
68795e93 760{
21312124
NIS
761 if (!ssv)
762 return;
6b85e4fe 763 recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
68795e93
NIS
764}
765
afe38520
DM
766/* handles calls from lock() builtin via PL_lockhook */
767
21312124
NIS
768void
769Perl_sharedsv_locksv(pTHX_ SV *sv)
770{
afe38520
DM
771 shared_sv* shared;
772
773 if(SvROK(sv))
774 sv = SvRV(sv);
38875929 775 shared = Perl_sharedsv_find(aTHX_ sv);
afe38520
DM
776 if(!shared)
777 croak("lock can only be used on shared values");
778 Perl_sharedsv_lock(aTHX_ shared);
b050c948
AB
779}
780
21312124 781=head1 Shared SV Functions
b050c948 782
21312124 783=for apidoc sharedsv_init
b050c948 784
21312124 785Saves a space for keeping SVs wider than an interpreter,
b050c948 786
21312124
NIS
787=cut
788
789void
790Perl_sharedsv_init(pTHX)
791{
792 dTHXc;
793 /* This pair leaves us in shared context ... */
794 PL_sharedsv_space = perl_alloc();
795 perl_construct(PL_sharedsv_space);
796 CALLER_CONTEXT;
6d56dc1c 797 recursive_lock_init(aTHX_ &PL_sharedsv_lock);
21312124
NIS
798 PL_lockhook = &Perl_sharedsv_locksv;
799 PL_sharehook = &Perl_sharedsv_share;
b050c948
AB
800}
801
73e09c8f
JH
802#endif /* USE_ITHREADS */
803
21312124 804MODULE = threads::shared PACKAGE = threads::shared::tie
b050c948 805
21312124 806PROTOTYPES: DISABLE
b050c948 807
73e09c8f 808#ifdef USE_ITHREADS
6b85e4fe 809
21312124
NIS
810void
811PUSH(shared_sv *shared, ...)
812CODE:
813 dTHXc;
814 int i;
21312124
NIS
815 for(i = 1; i < items; i++) {
816 SV* tmp = newSVsv(ST(i));
a446a88f 817 shared_sv *target;
6d56dc1c 818 ENTER_LOCK;
a446a88f 819 target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
6b85e4fe 820 sharedsv_scalar_store(aTHX_ tmp, target);
21312124
NIS
821 SHARED_CONTEXT;
822 av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
b0cd0593 823 SvREFCNT_inc(SHAREDSvPTR(target));
a446a88f 824 SHARED_RELEASE;
21312124
NIS
825 SvREFCNT_dec(tmp);
826 }
b050c948 827
21312124
NIS
828void
829UNSHIFT(shared_sv *shared, ...)
830CODE:
831 dTHXc;
832 int i;
6d56dc1c 833 ENTER_LOCK;
21312124
NIS
834 SHARED_CONTEXT;
835 av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
836 CALLER_CONTEXT;
837 for(i = 1; i < items; i++) {
838 SV* tmp = newSVsv(ST(i));
839 shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
6b85e4fe 840 sharedsv_scalar_store(aTHX_ tmp, target);
21312124
NIS
841 SHARED_CONTEXT;
842 av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
b0cd0593 843 SvREFCNT_inc(SHAREDSvPTR(target));
21312124
NIS
844 CALLER_CONTEXT;
845 SvREFCNT_dec(tmp);
846 }
6d56dc1c 847 LEAVE_LOCK;
b050c948 848
21312124
NIS
849void
850POP(shared_sv *shared)
851CODE:
852 dTHXc;
853 SV* sv;
6d56dc1c 854 ENTER_LOCK;
21312124
NIS
855 SHARED_CONTEXT;
856 sv = av_pop((AV*)SHAREDSvPTR(shared));
857 CALLER_CONTEXT;
9b018978 858 ST(0) = sv_newmortal();
21312124 859 Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
9b018978 860 SvREFCNT_dec(sv);
6d56dc1c 861 LEAVE_LOCK;
21312124 862 XSRETURN(1);
b050c948 863
21312124
NIS
864void
865SHIFT(shared_sv *shared)
866CODE:
867 dTHXc;
868 SV* sv;
6d56dc1c 869 ENTER_LOCK;
21312124
NIS
870 SHARED_CONTEXT;
871 sv = av_shift((AV*)SHAREDSvPTR(shared));
872 CALLER_CONTEXT;
9b018978 873 ST(0) = sv_newmortal();
21312124 874 Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
9b018978 875 SvREFCNT_dec(sv);
6d56dc1c 876 LEAVE_LOCK;
21312124 877 XSRETURN(1);
b050c948 878
21312124
NIS
879void
880EXTEND(shared_sv *shared, IV count)
881CODE:
882 dTHXc;
883 SHARED_EDIT;
884 av_extend((AV*)SHAREDSvPTR(shared), count);
885 SHARED_RELEASE;
b050c948 886
21312124 887void
6b85e4fe
NIS
888STORESIZE(shared_sv *shared,IV count)
889CODE:
890 dTHXc;
891 SHARED_EDIT;
892 av_fill((AV*) SHAREDSvPTR(shared), count);
893 SHARED_RELEASE;
894
895
896
897
898void
21312124
NIS
899EXISTS(shared_sv *shared, SV *index)
900CODE:
901 dTHXc;
902 bool exists;
903 SHARED_EDIT;
904 if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
905 exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
906 }
907 else {
6b85e4fe
NIS
908 STRLEN len;
909 char *key = SvPV(index,len);
910 exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
21312124
NIS
911 }
912 SHARED_RELEASE;
913 ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
914 XSRETURN(1);
b050c948
AB
915
916
917void
21312124
NIS
918FIRSTKEY(shared_sv *shared)
919CODE:
920 dTHXc;
921 char* key = NULL;
922 I32 len = 0;
923 HE* entry;
6d56dc1c 924 ENTER_LOCK;
21312124
NIS
925 SHARED_CONTEXT;
926 hv_iterinit((HV*) SHAREDSvPTR(shared));
927 entry = hv_iternext((HV*) SHAREDSvPTR(shared));
928 if (entry) {
929 key = hv_iterkey(entry,&len);
930 CALLER_CONTEXT;
931 ST(0) = sv_2mortal(newSVpv(key, len));
932 } else {
933 CALLER_CONTEXT;
934 ST(0) = &PL_sv_undef;
935 }
6d56dc1c 936 LEAVE_LOCK;
21312124 937 XSRETURN(1);
b050c948 938
866fba46 939void
21312124
NIS
940NEXTKEY(shared_sv *shared, SV *oldkey)
941CODE:
942 dTHXc;
943 char* key = NULL;
944 I32 len = 0;
945 HE* entry;
6d56dc1c 946 ENTER_LOCK;
21312124
NIS
947 SHARED_CONTEXT;
948 entry = hv_iternext((HV*) SHAREDSvPTR(shared));
6b85e4fe 949 if (entry) {
21312124
NIS
950 key = hv_iterkey(entry,&len);
951 CALLER_CONTEXT;
952 ST(0) = sv_2mortal(newSVpv(key, len));
953 } else {
954 CALLER_CONTEXT;
955 ST(0) = &PL_sv_undef;
956 }
6d56dc1c 957 LEAVE_LOCK;
21312124
NIS
958 XSRETURN(1);
959
960MODULE = threads::shared PACKAGE = threads::shared
961
962PROTOTYPES: ENABLE
866fba46 963
68795e93 964void
9c4972d9
NIS
965_id(SV *ref)
966 PROTOTYPE: \[$@%]
967CODE:
968 shared_sv *shared;
afe38520 969 ref = SvRV(ref);
9c4972d9
NIS
970 if(SvROK(ref))
971 ref = SvRV(ref);
436c6dd3 972 if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
9c4972d9
NIS
973 ST(0) = sv_2mortal(newSViv(PTR2IV(shared)));
974 XSRETURN(1);
975 }
976 XSRETURN_UNDEF;
977
978
979void
6b85e4fe 980_refcnt(SV *ref)
a446a88f
NIS
981 PROTOTYPE: \[$@%]
982CODE:
983 shared_sv *shared;
afe38520 984 ref = SvRV(ref);
a446a88f
NIS
985 if(SvROK(ref))
986 ref = SvRV(ref);
436c6dd3 987 if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
a446a88f
NIS
988 if (SHAREDSvPTR(shared)) {
989 ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
990 XSRETURN(1);
991 }
992 else {
436c6dd3 993 Perl_warn(aTHX_ "%" SVf " s=%p has no shared SV",ST(0),shared);
a446a88f
NIS
994 }
995 }
996 else {
436c6dd3 997 Perl_warn(aTHX_ "%" SVf " is not shared",ST(0));
a446a88f
NIS
998 }
999 XSRETURN_UNDEF;
1000
caf25f3b 1001SV*
a446a88f
NIS
1002share(SV *ref)
1003 PROTOTYPE: \[$@%]
1004 CODE:
56fcff86
AB
1005 if(!SvROK(ref))
1006 Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
afe38520 1007 ref = SvRV(ref);
a446a88f
NIS
1008 if(SvROK(ref))
1009 ref = SvRV(ref);
38875929 1010 Perl_sharedsv_share(aTHX_ ref);
caf25f3b
AB
1011 RETVAL = newRV(ref);
1012 OUTPUT:
1013 RETVAL
a446a88f
NIS
1014
1015void
21312124 1016lock_enabled(SV *ref)
ce127893 1017 PROTOTYPE: \[$@%]
6f942b98
AB
1018 CODE:
1019 shared_sv* shared;
56fcff86
AB
1020 if(!SvROK(ref))
1021 Perl_croak(aTHX_ "Argument to lock needs to be passed as ref");
afe38520 1022 ref = SvRV(ref);
6f942b98
AB
1023 if(SvROK(ref))
1024 ref = SvRV(ref);
38875929 1025 shared = Perl_sharedsv_find(aTHX_ ref);
21312124
NIS
1026 if(!shared)
1027 croak("lock can only be used on shared values");
1028 Perl_sharedsv_lock(aTHX_ shared);
6f942b98
AB
1029
1030void
21312124 1031cond_wait_enabled(SV *ref)
ce127893 1032 PROTOTYPE: \[$@%]
6f942b98
AB
1033 CODE:
1034 shared_sv* shared;
1035 int locks;
56fcff86
AB
1036 if(!SvROK(ref))
1037 Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
afe38520 1038 ref = SvRV(ref);
6f942b98
AB
1039 if(SvROK(ref))
1040 ref = SvRV(ref);
1041 shared = Perl_sharedsv_find(aTHX_ ref);
1042 if(!shared)
1043 croak("cond_wait can only be used on shared values");
6d56dc1c 1044 if(shared->lock.owner != aTHX)
6f942b98 1045 croak("You need a lock before you can cond_wait");
6d56dc1c
NIS
1046 /* Stealing the members of the lock object worries me - NI-S */
1047 MUTEX_LOCK(&shared->lock.mutex);
1048 shared->lock.owner = NULL;
39f33d92
AB
1049 locks = shared->lock.locks;
1050 shared->lock.locks = 0;
89661126
AB
1051
1052 /* since we are releasing the lock here we need to tell other
1053 people that is ok to go ahead and use it */
1054 COND_SIGNAL(&shared->lock.cond);
6d56dc1c 1055 COND_WAIT(&shared->user_cond, &shared->lock.mutex);
89661126
AB
1056 while(shared->lock.owner != NULL) {
1057 COND_WAIT(&shared->lock.cond,&shared->lock.mutex);
1058 }
6d56dc1c
NIS
1059 shared->lock.owner = aTHX;
1060 shared->lock.locks = locks;
1061 MUTEX_UNLOCK(&shared->lock.mutex);
6f942b98 1062
21312124
NIS
1063void
1064cond_signal_enabled(SV *ref)
ce127893 1065 PROTOTYPE: \[$@%]
6f942b98
AB
1066 CODE:
1067 shared_sv* shared;
56fcff86
AB
1068 if(!SvROK(ref))
1069 Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
afe38520 1070 ref = SvRV(ref);
6f942b98
AB
1071 if(SvROK(ref))
1072 ref = SvRV(ref);
1073 shared = Perl_sharedsv_find(aTHX_ ref);
38875929
DM
1074 if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1075 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1076 "cond_signal() called on unlocked variable");
6f942b98
AB
1077 if(!shared)
1078 croak("cond_signal can only be used on shared values");
1079 COND_SIGNAL(&shared->user_cond);
1080
21312124
NIS
1081void
1082cond_broadcast_enabled(SV *ref)
ce127893 1083 PROTOTYPE: \[$@%]
6f942b98
AB
1084 CODE:
1085 shared_sv* shared;
56fcff86
AB
1086 if(!SvROK(ref))
1087 Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
afe38520 1088 ref = SvRV(ref);
6f942b98
AB
1089 if(SvROK(ref))
1090 ref = SvRV(ref);
1091 shared = Perl_sharedsv_find(aTHX_ ref);
1092 if(!shared)
1093 croak("cond_broadcast can only be used on shared values");
38875929
DM
1094 if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1095 Perl_warner(aTHX_ packWARN(WARN_THREADS),
1096 "cond_broadcast() called on unlocked variable");
6f942b98 1097 COND_BROADCAST(&shared->user_cond);
b050c948 1098
5c360ac5
AB
1099
1100SV*
1101bless(SV* ref, ...);
1102 PROTOTYPE: $;$
1103 CODE:
1104 {
1105 HV* stash;
1106 shared_sv* shared;
1107 if (items == 1)
1108 stash = CopSTASH(PL_curcop);
1109 else {
1110 SV* ssv = ST(1);
1111 STRLEN len;
1112 char *ptr;
1113
1114 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
1115 Perl_croak(aTHX_ "Attempt to bless into a reference");
1116 ptr = SvPV(ssv,len);
1117 if (ckWARN(WARN_MISC) && len == 0)
1118 Perl_warner(aTHX_ packWARN(WARN_MISC),
1119 "Explicit blessing to '' (assuming package main)");
1120 stash = gv_stashpvn(ptr, len, TRUE);
1121 }
1122 SvREFCNT_inc(ref);
1123 (void)sv_bless(ref, stash);
1124 RETVAL = ref;
1125 shared = Perl_sharedsv_find(aTHX_ ref);
1126 if(shared) {
1127 dTHXc;
1128 ENTER_LOCK;
1129 SHARED_CONTEXT;
1130 {
1131 SV* fake_stash = newSVpv(HvNAME(stash),0);
1132 (void)sv_bless(SHAREDSvPTR(shared),(HV*)fake_stash);
1133 }
1134 CALLER_CONTEXT;
1135 LEAVE_LOCK;
1136 }
1137 }
1138 OUTPUT:
1139 RETVAL
1140
73e09c8f
JH
1141#endif /* USE_ITHREADS */
1142
68795e93
NIS
1143BOOT:
1144{
73e09c8f 1145#ifdef USE_ITHREADS
68795e93 1146 Perl_sharedsv_init(aTHX);
73e09c8f 1147#endif /* USE_ITHREADS */
68795e93 1148}
73e09c8f
JH
1149
1150
1151