This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Skip tests that require Data::Dumper if it is not built
[perl5.git] / ext / threads / shared / shared.xs
1 /*    shared.xs
2  *
3  *    Copyright (c) 2001-2002, 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  * "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  */
15
16 #define PERL_NO_GET_CONTEXT
17 #include "EXTERN.h"
18 #include "perl.h"
19 #include "XSUB.h"
20
21 #ifdef USE_ITHREADS
22
23 #define SHAREDSvPTR(a)      ((a)->sv)
24
25 /*
26  * The shared things need an intepreter to live in ...
27  */
28 PerlInterpreter *PL_sharedsv_space;             /* The shared sv space */
29 /* To access shared space we fake aTHX in this scope and thread's context */
30
31 /* bug #24255: we include ENTER+SAVETMPS/FREETMPS+LEAVE with
32  * SHARED_CONTEXT/CALLER_CONTEXT macros, so that any mortals etc created
33  * while in the shared interpreter context don't languish */
34
35 #define SHARED_CONTEXT \
36     STMT_START {                                        \
37         PERL_SET_CONTEXT((aTHX = PL_sharedsv_space));   \
38         ENTER;                                          \
39         SAVETMPS;                                       \
40     } STMT_END
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
45
46 /* and use it to switch back */
47 #define CALLER_CONTEXT                                  \
48     STMT_START {                                        \
49         FREETMPS;                                       \
50         LEAVE;                                          \
51         PERL_SET_CONTEXT((aTHX = caller_perl));         \
52     } STMT_END
53
54 /*
55  * Only one thread at a time is allowed to mess with shared space.
56  */
57
58 typedef struct
59 {
60  perl_mutex              mutex;
61  PerlInterpreter        *owner;
62  I32                     locks;
63  perl_cond               cond;
64 #ifdef DEBUG_LOCKS
65  char *                  file;
66  int                     line;
67 #endif
68 } recursive_lock_t;
69
70 recursive_lock_t PL_sharedsv_lock;       /* Mutex protecting the shared sv space */
71
72 void
73 recursive_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
80 void
81 recursive_lock_destroy(pTHX_ recursive_lock_t *lock)
82 {
83     MUTEX_DESTROY(&lock->mutex);
84     COND_DESTROY(&lock->cond);
85 }
86
87 void
88 recursive_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 }
102
103 void
104 recursive_lock_acquire(pTHX_ recursive_lock_t *lock,char *file,int line)
105 {
106     assert(aTHX);
107     MUTEX_LOCK(&lock->mutex);
108     if (lock->owner == aTHX) {
109         lock->locks++;
110     }
111     else {
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
117             COND_WAIT(&lock->cond,&lock->mutex);
118         }
119         lock->locks = 1;
120         lock->owner = aTHX;
121 #ifdef DEBUG_LOCKS
122         lock->file  = file;
123         lock->line  = line;
124 #endif
125     }
126     MUTEX_UNLOCK(&lock->mutex);
127     SAVEDESTRUCTOR_X(recursive_lock_release,lock);
128 }
129
130 #define ENTER_LOCK         STMT_START { \
131                               ENTER; \
132                               recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__);   \
133                             } STMT_END
134
135 #define LEAVE_LOCK       LEAVE
136
137
138 /* A common idiom is to acquire access and switch in ... */
139 #define SHARED_EDIT         STMT_START {        \
140                                 ENTER_LOCK;     \
141                                 SHARED_CONTEXT; \
142                             } STMT_END
143
144 /* then switch out and release access. */
145 #define SHARED_RELEASE     STMT_START { \
146                                 CALLER_CONTEXT; \
147                                 LEAVE_LOCK;     \
148                             } STMT_END
149
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 */
162
163 typedef struct {
164     SV                 *sv;             /* The actual SV - in shared space */
165     recursive_lock_t    lock;
166     perl_cond           user_cond;      /* For user-level conditions */
167 } shared_sv;
168
169 /* The SV in shared-space has a back-pointer to the shared_sv
170    struct associated with it PERL_MAGIC_ext.
171
172    The vtable used has just one entry - when the SV goes away
173    we free the memory for the above.
174
175  */
176
177 int
178 sharedsv_shared_mg_free(pTHX_ SV *sv, MAGIC *mg)
179 {
180     shared_sv *shared = (shared_sv *) mg->mg_ptr;
181     assert( aTHX == PL_sharedsv_space );
182     if (shared) {
183         recursive_lock_destroy(aTHX_ &shared->lock);
184         COND_DESTROY(&shared->user_cond);
185         PerlMemShared_free(shared);
186         mg->mg_ptr = NULL;
187     }
188     return 0;
189 }
190
191 MGVTBL 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
208 MGVTBL sharedsv_scalar_vtbl;    /* scalars have this vtable */
209 MGVTBL sharedsv_array_vtbl;     /* hashes and arrays have this - like 'tie' */
210 MGVTBL 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
217
218 /* Accessor to convert threads::shared::tie objects back shared_sv * */
219 shared_sv *
220 SV_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
230 =for apidoc sharedsv_find
231
232 Given a private side SV tries to find if the SV has a shared backend,
233 by looking for the magic.
234
235 =cut
236
237 shared_sv *
238 Perl_sharedsv_find(pTHX_ SV *sv)
239 {
240     MAGIC *mg;
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) {
247                 return (shared_sv *) mg->mg_ptr;
248             }
249             break;
250         default:
251             /* This should work for elements as well as they
252              * have scalar magic as well as their element magic
253              */
254             if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar))
255                 && mg->mg_virtual == &sharedsv_scalar_vtbl) {
256                 return (shared_sv *) mg->mg_ptr;
257             }
258             break;
259         }
260     }
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     }
265     return NULL;
266 }
267
268 /*
269  *  Almost all the pain is in this routine.
270  *
271  */
272
273 shared_sv *
274 Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data)
275 {
276     dTHXc;
277     MAGIC *mg = 0;
278     SV *sv    = (psv) ? *psv : Nullsv;
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 */
284     assert ( PL_sharedsv_lock.owner == aTHX );
285
286     /* First try and get existing global data structure */
287
288     /* Try shared SV as 1st choice */
289     if (!data && ssv && SvTYPE(ssv) >= SVt_PVMG) {
290         if( (mg = mg_find(ssv, PERL_MAGIC_ext)) ){
291             data = (shared_sv *) mg->mg_ptr;
292         }
293     }
294
295     /* Next see if private SV is associated with something */
296     if (!data && sv) {
297         data = Perl_sharedsv_find(aTHX_ sv);
298     }
299
300     /* If neither of those then create a new one */
301     if (!data) {
302             SHARED_CONTEXT;
303             if (!ssv) {
304                 ssv = newSV(0);
305                 SvREFCNT(ssv) = 0;
306             }
307             data = PerlMemShared_malloc(sizeof(shared_sv));
308             Zero(data,1,shared_sv);
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);
313             recursive_lock_init(aTHX_ &data->lock);
314             COND_INIT(&data->user_cond);
315             CALLER_CONTEXT;
316     }
317
318     if (!ssv)
319         ssv = SHAREDSvPTR(data);
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)) {
325         SHARED_CONTEXT;
326         sv_upgrade(ssv, SvTYPE(*psv));
327         if (SvTYPE(ssv) == SVt_PVAV)    /* #24061 */
328             AvREAL_on(ssv);
329         CALLER_CONTEXT;
330     }
331
332     /* Now if requested allocate private SV */
333     if (psv && !sv) {
334         *psv = sv = newSV(0);
335     }
336
337     /* Finally if private SV exists check and add magic */
338     if (sv) {
339         MAGIC *mg = 0;
340         if (SvTYPE(sv) < SvTYPE(ssv)) {
341             sv_upgrade(sv, SvTYPE(ssv));
342         }
343         switch(SvTYPE(sv)) {
344         case SVt_PVAV:
345         case SVt_PVHV:
346             if (!(mg = mg_find(sv, PERL_MAGIC_tied))
347                 || mg->mg_virtual != &sharedsv_array_vtbl
348                 || (shared_sv *) mg->mg_ptr != data) {
349                 SV *obj = newSV(0);
350                 sv_setref_iv(obj, "threads::shared::tie",PTR2IV(data));
351                 if (mg) {
352                     sv_unmagic(sv, PERL_MAGIC_tied);
353                 }
354                 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
355                                 (char *) data, 0);
356                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
357                 SvREFCNT_inc(ssv);
358                 SvREFCNT_dec(obj);
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                 }
366             }
367             break;
368
369         default:
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) {
375                     sv_unmagic(sv, PERL_MAGIC_shared_scalar);
376                 }
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);
380                 SvREFCNT_inc(ssv);
381             }
382             break;
383         }
384         assert ( Perl_sharedsv_find(aTHX_ *psv) == data );
385     }
386     return data;
387 }
388
389 void
390 Perl_sharedsv_free(pTHX_ shared_sv *shared)
391 {
392     if (shared) {
393         dTHXc;
394         SHARED_EDIT;
395         SvREFCNT_dec(SHAREDSvPTR(shared));
396         SHARED_RELEASE;
397     }
398 }
399
400 void
401 Perl_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;
411
412     default:
413         ENTER_LOCK;
414         Perl_sharedsv_associate(aTHX_ &sv, 0, 0);
415         LEAVE_LOCK;
416         SvSETMAGIC(sv);
417         break;
418     }
419 }
420
421 #if defined(WIN32) || defined(OS2)
422 #  define ABS2RELMILLI(abs)        \
423     do {                                \
424         abs -= (double)time(NULL);      \
425         if (abs > 0) { abs *= 1000; }   \
426         else         { abs  = 0;    }   \
427     } while (0)
428 #endif /* WIN32 || OS2 */
429
430 bool
431 Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs)
432 {
433 #if defined(NETWARE) || defined(FAKE_THREADS) || defined(I_MACH_CTHREADS)
434     Perl_croak_nocontext("cond_timedwait not supported on this platform");
435 #else
436 #  ifdef WIN32
437     int got_it = 0;
438
439     ABS2RELMILLI(abs);
440
441     cond->waiters++;
442     MUTEX_UNLOCK(mut);
443     /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */
444     switch (WaitForSingleObject(cond->sem, (DWORD)abs)) {
445         case WAIT_OBJECT_0:   got_it = 1; break;
446         case WAIT_TIMEOUT:                break;
447         default:
448             /* WAIT_FAILED? WAIT_ABANDONED? others? */
449             Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError());
450             break;
451     }
452     MUTEX_LOCK(mut);
453     cond->waiters--;
454     return got_it;
455 #  else
456 #    ifdef OS2
457     int rc, got_it = 0;
458     STRLEN n_a;
459
460     ABS2RELMILLI(abs);
461
462     if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET))
463         Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset");
464     MUTEX_UNLOCK(mut);
465     if (CheckOSError(DosWaitEventSem(*cond,abs))
466         && (rc != ERROR_INTERRUPT))
467         croak_with_os2error("panic: cond_timedwait");
468     if (rc == ERROR_INTERRUPT) errno = EINTR;
469     MUTEX_LOCK(mut);
470     return got_it;
471 #    else         /* hope you're I_PTHREAD! */
472     struct timespec ts;
473     int got_it = 0;
474
475     ts.tv_sec = (long)abs;
476     abs -= (NV)ts.tv_sec;
477     ts.tv_nsec = (long)(abs * 1000000000.0);
478
479     switch (pthread_cond_timedwait(cond, mut, &ts)) {
480         case 0:         got_it = 1; break;
481         case ETIMEDOUT:             break;
482         default:
483             Perl_croak_nocontext("panic: cond_timedwait");
484             break;
485     }
486     return got_it;
487 #    endif /* OS2 */
488 #  endif /* WIN32 */
489 #endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */
490 }
491
492 /* MAGIC (in mg.h sense) hooks */
493
494 int
495 sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
496 {
497     shared_sv *shared = (shared_sv *) mg->mg_ptr;
498     assert(shared);
499
500     ENTER_LOCK;
501     if (SHAREDSvPTR(shared)) {
502         if (SvROK(SHAREDSvPTR(shared))) {
503             SV *obj = Nullsv;
504             Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
505             sv_setsv_nomg(sv, &PL_sv_undef);
506             SvRV(sv) = obj;
507             SvROK_on(sv);
508             
509         }
510         else {
511             sv_setsv_nomg(sv, SHAREDSvPTR(shared));
512         }
513     }
514     LEAVE_LOCK;
515     return 0;
516 }
517
518 void
519 sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared)
520 {
521     dTHXc;
522     bool allowed = TRUE;
523     if (SvROK(sv)) {
524         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
525         if (target) {
526             SV *tmp;
527             SHARED_CONTEXT;
528             tmp = newRV(SHAREDSvPTR(target));
529             sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
530             SvREFCNT_dec(tmp);
531             if(SvOBJECT(SvRV(sv))) {
532               SV* fake_stash = newSVpv(HvNAME(SvSTASH(SvRV(sv))),0);
533               SvOBJECT_on(SHAREDSvPTR(target));
534               SvSTASH(SHAREDSvPTR(target)) = (HV*)fake_stash;
535             }
536             CALLER_CONTEXT;
537         }
538         else {
539             allowed = FALSE;
540         }
541     }
542     else {
543         SvTEMP_off(sv);
544         SHARED_CONTEXT;
545         sv_setsv_nomg(SHAREDSvPTR(shared), sv);
546         if(SvOBJECT(sv)) {
547           SV* fake_stash = newSVpv(HvNAME(SvSTASH(sv)),0);
548           SvOBJECT_on(SHAREDSvPTR(shared));
549           SvSTASH(SHAREDSvPTR(shared)) = (HV*)fake_stash;
550         }
551         CALLER_CONTEXT;
552     }
553     if (!allowed) {
554         Perl_croak(aTHX_ "Invalid value for shared scalar");
555     }
556 }
557
558 int
559 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
560 {
561     shared_sv *shared;
562     ENTER_LOCK;
563     /* We call associate to potentially upgrade shared side SV */
564     shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr);
565     assert(shared);
566     sharedsv_scalar_store(aTHX_ sv, shared);
567     LEAVE_LOCK;
568     return 0;
569 }
570
571 int
572 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
573 {
574     shared_sv *shared = (shared_sv *) mg->mg_ptr;
575 #if 0
576     assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
577 #endif
578     Perl_sharedsv_free(aTHX_ shared);
579     return 0;
580 }
581
582 int
583 sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
584 {
585     return 0;
586 }
587
588 /*
589  * Called during cloning of new threads
590  */
591 int
592 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
593 {
594     shared_sv *shared = (shared_sv *) mg->mg_ptr;
595     if (shared) {
596         SvREFCNT_inc(SHAREDSvPTR(shared));
597     }
598     return 0;
599 }
600
601 MGVTBL sharedsv_scalar_vtbl = {
602  sharedsv_scalar_mg_get,        /* get */
603  sharedsv_scalar_mg_set,        /* set */
604  0,                             /* len */
605  sharedsv_scalar_mg_clear,      /* clear */
606  sharedsv_scalar_mg_free,       /* free */
607  0,                             /* copy */
608  sharedsv_scalar_mg_dup         /* dup */
609 };
610
611 /* Now the arrays/hashes stuff */
612 int
613 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
614 {
615     dTHXc;
616     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
617     shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
618     SV** svp;
619
620     assert ( shared );
621     assert ( SHAREDSvPTR(shared) );
622
623     ENTER_LOCK;
624     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
625         assert ( mg->mg_ptr == 0 );
626         SHARED_CONTEXT;
627         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
628     }
629     else {
630         char *key = mg->mg_ptr;
631         STRLEN len = mg->mg_len;
632         assert ( mg->mg_ptr != 0 );
633         if (mg->mg_len == HEf_SVKEY) {
634            key = SvPV((SV *) mg->mg_ptr, len);
635         }
636         SHARED_CONTEXT;
637         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0);
638     }
639     CALLER_CONTEXT;
640     if (svp) {
641         /* Exists in the array */
642         target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
643         sv_setsv(sv, *svp);
644     }
645     else {
646         /* Not in the array */
647         sv_setsv(sv, &PL_sv_undef);
648     }
649     LEAVE_LOCK;
650     return 0;
651 }
652
653 int
654 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
655 {
656     dTHXc;
657     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
658     shared_sv *target;
659     SV **svp;
660     /* Theory - SV itself is magically shared - and we have ordered the
661        magic such that by the time we get here it has been stored
662        to its shared counterpart
663      */
664     ENTER_LOCK;
665     assert(shared);
666     assert(SHAREDSvPTR(shared));
667     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
668         assert ( mg->mg_ptr == 0 );
669         SHARED_CONTEXT;
670         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 1);
671     }
672     else {
673         char *key = mg->mg_ptr;
674         STRLEN len = mg->mg_len;
675         assert ( mg->mg_ptr != 0 );
676         if (mg->mg_len == HEf_SVKEY)
677            key = SvPV((SV *) mg->mg_ptr, len);
678         SHARED_CONTEXT;
679         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 1);
680     }
681     CALLER_CONTEXT;
682     target = Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
683     sharedsv_scalar_store(aTHX_ sv, target);
684     LEAVE_LOCK;
685     return 0;
686 }
687
688 int
689 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
690 {
691     dTHXc;
692     MAGIC *shmg;
693     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
694     ENTER_LOCK;
695     sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
696     if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
697         sharedsv_scalar_mg_get(aTHX_ sv, shmg);
698     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
699         SHARED_CONTEXT;
700         av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
701     }
702     else {
703         char *key = mg->mg_ptr;
704         STRLEN len = mg->mg_len;
705         assert ( mg->mg_ptr != 0 );
706         if (mg->mg_len == HEf_SVKEY)
707            key = SvPV((SV *) mg->mg_ptr, len);
708         SHARED_CONTEXT;
709         hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD);
710     }
711     CALLER_CONTEXT;
712     LEAVE_LOCK;
713     return 0;
714 }
715
716 int
717 sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
718 {
719     Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj));
720     return 0;
721 }
722
723 int
724 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
725 {
726     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
727     SvREFCNT_inc(SHAREDSvPTR(shared));
728     mg->mg_flags |= MGf_DUP;
729     return 0;
730 }
731
732 MGVTBL sharedsv_elem_vtbl = {
733  sharedsv_elem_mg_FETCH,        /* get */
734  sharedsv_elem_mg_STORE,        /* set */
735  0,                             /* len */
736  sharedsv_elem_mg_DELETE,       /* clear */
737  sharedsv_elem_mg_free,         /* free */
738  0,                             /* copy */
739  sharedsv_elem_mg_dup           /* dup */
740 };
741
742 U32
743 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
744 {
745     dTHXc;
746     shared_sv *shared = (shared_sv *) mg->mg_ptr;
747     U32 val;
748     SHARED_EDIT;
749     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
750         val = av_len((AV*) SHAREDSvPTR(shared));
751     }
752     else {
753         /* not actually defined by tie API but ... */
754         val = HvKEYS((HV*) SHAREDSvPTR(shared));
755     }
756     SHARED_RELEASE;
757     return val;
758 }
759
760 int
761 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
762 {
763     dTHXc;
764     shared_sv *shared = (shared_sv *) mg->mg_ptr;
765     SHARED_EDIT;
766     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
767         av_clear((AV*) SHAREDSvPTR(shared));
768     }
769     else {
770         hv_clear((HV*) SHAREDSvPTR(shared));
771     }
772     SHARED_RELEASE;
773     return 0;
774 }
775
776 int
777 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
778 {
779     Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
780     return 0;
781 }
782
783 /*
784  * This is called when perl is about to access an element of
785  * the array -
786  */
787 int
788 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
789                        SV *nsv, const char *name, int namlen)
790 {
791     shared_sv *shared = (shared_sv *) mg->mg_ptr;
792     MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
793                             toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
794                             name, namlen);
795     ENTER_LOCK;
796     SvREFCNT_inc(SHAREDSvPTR(shared));
797     LEAVE_LOCK;
798     nmg->mg_flags |= MGf_DUP;
799     return 1;
800 }
801
802 int
803 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
804 {
805     shared_sv *shared = (shared_sv *) mg->mg_ptr;
806     SvREFCNT_inc(SHAREDSvPTR(shared));
807     mg->mg_flags |= MGf_DUP;
808     return 0;
809 }
810
811 MGVTBL sharedsv_array_vtbl = {
812  0,                             /* get */
813  0,                             /* set */
814  sharedsv_array_mg_FETCHSIZE,   /* len */
815  sharedsv_array_mg_CLEAR,       /* clear */
816  sharedsv_array_mg_free,        /* free */
817  sharedsv_array_mg_copy,        /* copy */
818  sharedsv_array_mg_dup          /* dup */
819 };
820
821 =for apidoc sharedsv_unlock
822
823 Recursively unlocks a shared sv.
824
825 =cut
826
827 void
828 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
829 {
830     recursive_lock_release(aTHX_ &ssv->lock);
831 }
832
833 =for apidoc sharedsv_lock
834
835 Recursive locks on a sharedsv.
836 Locks are dynamically scoped at the level of the first lock.
837
838 =cut
839
840 void
841 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
842 {
843     if (!ssv)
844         return;
845     recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
846 }
847
848 /* handles calls from lock() builtin via PL_lockhook */
849
850 void
851 Perl_sharedsv_locksv(pTHX_ SV *sv)
852 {
853     shared_sv* shared;
854
855     if(SvROK(sv))
856         sv = SvRV(sv);
857     shared = Perl_sharedsv_find(aTHX_ sv);
858     if(!shared)
859        croak("lock can only be used on shared values");
860     Perl_sharedsv_lock(aTHX_ shared);
861 }
862
863 =head1 Shared SV Functions
864
865 =for apidoc sharedsv_init
866
867 Saves a space for keeping SVs wider than an interpreter,
868
869 =cut
870
871 void
872 Perl_sharedsv_init(pTHX)
873 {
874   dTHXc;
875   /* This pair leaves us in shared context ... */
876   PL_sharedsv_space = perl_alloc();
877   perl_construct(PL_sharedsv_space);
878   CALLER_CONTEXT;
879   recursive_lock_init(aTHX_ &PL_sharedsv_lock);
880   PL_lockhook = &Perl_sharedsv_locksv;
881   PL_sharehook = &Perl_sharedsv_share;
882 }
883
884 #endif /* USE_ITHREADS */
885
886 MODULE = threads::shared        PACKAGE = threads::shared::tie
887
888 PROTOTYPES: DISABLE
889
890 #ifdef USE_ITHREADS
891
892 void
893 PUSH(shared_sv *shared, ...)
894 CODE:
895         dTHXc;
896         int i;
897         for(i = 1; i < items; i++) {
898             SV* tmp = newSVsv(ST(i));
899             shared_sv *target;
900             ENTER_LOCK;
901             target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
902             sharedsv_scalar_store(aTHX_ tmp, target);
903             SHARED_CONTEXT;
904             av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
905             SvREFCNT_inc(SHAREDSvPTR(target));
906             SHARED_RELEASE;
907             SvREFCNT_dec(tmp);
908         }
909
910 void
911 UNSHIFT(shared_sv *shared, ...)
912 CODE:
913         dTHXc;
914         int i;
915         ENTER_LOCK;
916         SHARED_CONTEXT;
917         av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
918         CALLER_CONTEXT;
919         for(i = 1; i < items; i++) {
920             SV* tmp = newSVsv(ST(i));
921             shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
922             sharedsv_scalar_store(aTHX_ tmp, target);
923             SHARED_CONTEXT;
924             av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
925             SvREFCNT_inc(SHAREDSvPTR(target));
926             CALLER_CONTEXT;
927             SvREFCNT_dec(tmp);
928         }
929         LEAVE_LOCK;
930
931 void
932 POP(shared_sv *shared)
933 CODE:
934         dTHXc;
935         SV* sv;
936         ENTER_LOCK;
937         SHARED_CONTEXT;
938         sv = av_pop((AV*)SHAREDSvPTR(shared));
939         CALLER_CONTEXT;
940         ST(0) = sv_newmortal();
941         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
942         SvREFCNT_dec(sv);
943         LEAVE_LOCK;
944         XSRETURN(1);
945
946 void
947 SHIFT(shared_sv *shared)
948 CODE:
949         dTHXc;
950         SV* sv;
951         ENTER_LOCK;
952         SHARED_CONTEXT;
953         sv = av_shift((AV*)SHAREDSvPTR(shared));
954         CALLER_CONTEXT;
955         ST(0) = sv_newmortal();
956         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
957         SvREFCNT_dec(sv);
958         LEAVE_LOCK;
959         XSRETURN(1);
960
961 void
962 EXTEND(shared_sv *shared, IV count)
963 CODE:
964         dTHXc;
965         SHARED_EDIT;
966         av_extend((AV*)SHAREDSvPTR(shared), count);
967         SHARED_RELEASE;
968
969 void
970 STORESIZE(shared_sv *shared,IV count)
971 CODE:
972         dTHXc;
973         SHARED_EDIT;
974         av_fill((AV*) SHAREDSvPTR(shared), count);
975         SHARED_RELEASE;
976
977
978
979
980 void
981 EXISTS(shared_sv *shared, SV *index)
982 CODE:
983         dTHXc;
984         bool exists;
985         if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
986             SHARED_EDIT;
987             exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
988         }
989         else {
990             STRLEN len;
991             char *key = SvPV(index,len);
992             SHARED_EDIT;
993             exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
994         }
995         SHARED_RELEASE;
996         ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
997         XSRETURN(1);
998
999
1000 void
1001 FIRSTKEY(shared_sv *shared)
1002 CODE:
1003         dTHXc;
1004         char* key = NULL;
1005         I32 len = 0;
1006         HE* entry;
1007         ENTER_LOCK;
1008         SHARED_CONTEXT;
1009         hv_iterinit((HV*) SHAREDSvPTR(shared));
1010         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
1011         if (entry) {
1012                 key = hv_iterkey(entry,&len);
1013                 CALLER_CONTEXT;
1014                 ST(0) = sv_2mortal(newSVpv(key, len));
1015         } else {
1016              CALLER_CONTEXT;
1017              ST(0) = &PL_sv_undef;
1018         }
1019         LEAVE_LOCK;
1020         XSRETURN(1);
1021
1022 void
1023 NEXTKEY(shared_sv *shared, SV *oldkey)
1024 CODE:
1025         dTHXc;
1026         char* key = NULL;
1027         I32 len = 0;
1028         HE* entry;
1029         ENTER_LOCK;
1030         SHARED_CONTEXT;
1031         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
1032         if (entry) {
1033                 key = hv_iterkey(entry,&len);
1034                 CALLER_CONTEXT;
1035                 ST(0) = sv_2mortal(newSVpv(key, len));
1036         } else {
1037              CALLER_CONTEXT;
1038              ST(0) = &PL_sv_undef;
1039         }
1040         LEAVE_LOCK;
1041         XSRETURN(1);
1042
1043 MODULE = threads::shared                PACKAGE = threads::shared
1044
1045 PROTOTYPES: ENABLE
1046
1047 void
1048 _id(SV *ref)
1049         PROTOTYPE: \[$@%]
1050 CODE:
1051         shared_sv *shared;
1052         ref = SvRV(ref);
1053         if(SvROK(ref))
1054             ref = SvRV(ref);
1055         if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
1056             ST(0) = sv_2mortal(newSViv(PTR2IV(shared)));
1057             XSRETURN(1);
1058         }
1059         XSRETURN_UNDEF;
1060
1061
1062 void
1063 _refcnt(SV *ref)
1064         PROTOTYPE: \[$@%]
1065 CODE:
1066         shared_sv *shared;
1067         ref = SvRV(ref);
1068         if(SvROK(ref))
1069             ref = SvRV(ref);
1070         if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
1071           if (SHAREDSvPTR(shared)) {
1072             ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
1073             XSRETURN(1);
1074           }
1075           else {
1076              Perl_warn(aTHX_ "%" SVf " s=%p has no shared SV",ST(0),shared);
1077           }
1078         }
1079         else {
1080              Perl_warn(aTHX_ "%" SVf " is not shared",ST(0));
1081         }
1082         XSRETURN_UNDEF;
1083
1084 SV*
1085 share(SV *ref)
1086         PROTOTYPE: \[$@%]
1087         CODE:
1088         if(!SvROK(ref))
1089             Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
1090         ref = SvRV(ref);
1091         if(SvROK(ref))
1092             ref = SvRV(ref);
1093         Perl_sharedsv_share(aTHX_ ref);
1094         RETVAL = newRV(ref);
1095         OUTPUT:
1096         RETVAL
1097
1098 void
1099 lock_enabled(SV *ref)
1100         PROTOTYPE: \[$@%]
1101         CODE:
1102         shared_sv* shared;
1103         if(!SvROK(ref))
1104             Perl_croak(aTHX_ "Argument to lock needs to be passed as ref");
1105         ref = SvRV(ref);
1106         if(SvROK(ref))
1107             ref = SvRV(ref);
1108         shared = Perl_sharedsv_find(aTHX_ ref);
1109         if(!shared)
1110            croak("lock can only be used on shared values");
1111         Perl_sharedsv_lock(aTHX_ shared);
1112
1113 void
1114 cond_wait_enabled(SV *ref_cond, SV *ref_lock = 0)
1115         PROTOTYPE: \[$@%];\[$@%]
1116         PREINIT:
1117         shared_sv* shared;
1118         perl_cond* user_condition;
1119         int locks;
1120         int same = 0;
1121
1122         CODE:
1123         if (!ref_lock || ref_lock == ref_cond) same = 1;
1124
1125         if(!SvROK(ref_cond))
1126             Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
1127         ref_cond = SvRV(ref_cond);
1128         if(SvROK(ref_cond))
1129             ref_cond = SvRV(ref_cond);
1130         shared = Perl_sharedsv_find(aTHX_ ref_cond);
1131         if(!shared)
1132             croak("cond_wait can only be used on shared values");
1133
1134         user_condition = &shared->user_cond;
1135         if (! same) {
1136             if (!SvROK(ref_lock))
1137                 Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref");
1138             ref_lock = SvRV(ref_lock);
1139             if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1140             shared = Perl_sharedsv_find(aTHX_ ref_lock);
1141             if (!shared)
1142                 croak("cond_wait lock must be a shared value");
1143         }
1144         if(shared->lock.owner != aTHX)
1145             croak("You need a lock before you can cond_wait");
1146         /* Stealing the members of the lock object worries me - NI-S */
1147         MUTEX_LOCK(&shared->lock.mutex);
1148         shared->lock.owner = NULL;
1149         locks = shared->lock.locks;
1150         shared->lock.locks = 0;
1151
1152         /* since we are releasing the lock here we need to tell other
1153         people that is ok to go ahead and use it */
1154         COND_SIGNAL(&shared->lock.cond);
1155         COND_WAIT(user_condition, &shared->lock.mutex);
1156         while(shared->lock.owner != NULL) {
1157             /* OK -- must reacquire the lock */
1158             COND_WAIT(&shared->lock.cond, &shared->lock.mutex);
1159         }
1160         shared->lock.owner = aTHX;
1161         shared->lock.locks = locks;
1162         MUTEX_UNLOCK(&shared->lock.mutex);
1163
1164 int
1165 cond_timedwait_enabled(SV *ref_cond, double abs, SV *ref_lock = 0)
1166         PROTOTYPE: \[$@%]$;\[$@%]
1167         PREINIT:
1168         shared_sv* shared;
1169         perl_cond* user_condition;
1170         int locks;
1171         int same = 0;
1172
1173         CODE:
1174         if (!ref_lock || ref_cond == ref_lock) same = 1;
1175
1176         if(!SvROK(ref_cond))
1177             Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref");
1178         ref_cond = SvRV(ref_cond);
1179         if(SvROK(ref_cond))
1180             ref_cond = SvRV(ref_cond);
1181         shared = Perl_sharedsv_find(aTHX_ ref_cond);
1182         if(!shared)
1183             croak("cond_timedwait can only be used on shared values");
1184     
1185         user_condition = &shared->user_cond;
1186         if (! same) {
1187             if (!SvROK(ref_lock))
1188                 Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref");
1189             ref_lock = SvRV(ref_lock);
1190             if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1191             shared = Perl_sharedsv_find(aTHX_ ref_lock);
1192             if (!shared)
1193                 croak("cond_timedwait lock must be a shared value");
1194         }
1195         if(shared->lock.owner != aTHX)
1196             croak("You need a lock before you can cond_wait");
1197
1198         MUTEX_LOCK(&shared->lock.mutex);
1199         shared->lock.owner = NULL;
1200         locks = shared->lock.locks;
1201         shared->lock.locks = 0;
1202         /* since we are releasing the lock here we need to tell other
1203         people that is ok to go ahead and use it */
1204         COND_SIGNAL(&shared->lock.cond);
1205         RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &shared->lock.mutex, abs);
1206         while (shared->lock.owner != NULL) {
1207             /* OK -- must reacquire the lock... */
1208             COND_WAIT(&shared->lock.cond, &shared->lock.mutex);
1209         }
1210         shared->lock.owner = aTHX;
1211         shared->lock.locks = locks;
1212         MUTEX_UNLOCK(&shared->lock.mutex);
1213
1214         if (RETVAL == 0)
1215             XSRETURN_UNDEF;
1216         OUTPUT:
1217         RETVAL
1218
1219 void
1220 cond_signal_enabled(SV *ref)
1221         PROTOTYPE: \[$@%]
1222         CODE:
1223         shared_sv* shared;
1224         if(!SvROK(ref))
1225             Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
1226         ref = SvRV(ref);
1227         if(SvROK(ref))
1228             ref = SvRV(ref);
1229         shared = Perl_sharedsv_find(aTHX_ ref);
1230         if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1231             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1232                             "cond_signal() called on unlocked variable");
1233         if(!shared)
1234             croak("cond_signal can only be used on shared values");
1235         COND_SIGNAL(&shared->user_cond);
1236
1237 void
1238 cond_broadcast_enabled(SV *ref)
1239         PROTOTYPE: \[$@%]
1240         CODE:
1241         shared_sv* shared;
1242         if(!SvROK(ref))
1243             Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
1244         ref = SvRV(ref);
1245         if(SvROK(ref))
1246             ref = SvRV(ref);
1247         shared = Perl_sharedsv_find(aTHX_ ref);
1248         if(!shared)
1249             croak("cond_broadcast can only be used on shared values");
1250         if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1251             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1252                             "cond_broadcast() called on unlocked variable");
1253         COND_BROADCAST(&shared->user_cond);
1254
1255
1256 SV*
1257 bless(SV* ref, ...);
1258         PROTOTYPE: $;$
1259         CODE:
1260         {
1261           HV* stash;
1262           shared_sv* shared;
1263           if (items == 1)
1264             stash = CopSTASH(PL_curcop);
1265           else {
1266             SV* ssv = ST(1);
1267             STRLEN len;
1268             char *ptr;
1269             
1270             if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
1271               Perl_croak(aTHX_ "Attempt to bless into a reference");
1272             ptr = SvPV(ssv,len);
1273             if (ckWARN(WARN_MISC) && len == 0)
1274               Perl_warner(aTHX_ packWARN(WARN_MISC),
1275                           "Explicit blessing to '' (assuming package main)");
1276             stash = gv_stashpvn(ptr, len, TRUE);
1277           }
1278           SvREFCNT_inc(ref);
1279           (void)sv_bless(ref, stash);
1280           RETVAL = ref;
1281           shared = Perl_sharedsv_find(aTHX_ ref);
1282           if(shared) {
1283             dTHXc;
1284             ENTER_LOCK;
1285             SHARED_CONTEXT;
1286             {
1287               SV* fake_stash = newSVpv(HvNAME(stash),0);
1288               (void)sv_bless(SHAREDSvPTR(shared),(HV*)fake_stash);
1289             }
1290             CALLER_CONTEXT;
1291             LEAVE_LOCK;
1292           }
1293         }
1294         OUTPUT:
1295         RETVAL          
1296
1297 #endif /* USE_ITHREADS */
1298
1299 BOOT:
1300 {
1301 #ifdef USE_ITHREADS
1302      Perl_sharedsv_init(aTHX);
1303 #endif /* USE_ITHREADS */
1304 }
1305
1306
1307