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