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