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