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