This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ithreads: cond_signal() on a non-shared object coredumped
[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         if (SvROK(*svp)) {
643             SV *obj = Nullsv;
644             Perl_sharedsv_associate(aTHX_ &obj, SvRV(*svp), NULL);
645             sv_setsv_nomg(sv, &PL_sv_undef);
646             SvRV(sv) = obj;
647             SvROK_on(sv);
648             SvSETMAGIC(sv);
649         }
650         else {
651             target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
652             sv_setsv(sv, *svp);
653         }
654     }
655     else {
656         /* Not in the array */
657         sv_setsv(sv, &PL_sv_undef);
658     }
659     LEAVE_LOCK;
660     return 0;
661 }
662
663 int
664 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
665 {
666     dTHXc;
667     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
668     shared_sv *target;
669     SV **svp;
670     /* Theory - SV itself is magically shared - and we have ordered the
671        magic such that by the time we get here it has been stored
672        to its shared counterpart
673      */
674     ENTER_LOCK;
675     assert(shared);
676     assert(SHAREDSvPTR(shared));
677     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
678         assert ( mg->mg_ptr == 0 );
679         SHARED_CONTEXT;
680         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 1);
681     }
682     else {
683         char *key = mg->mg_ptr;
684         STRLEN len = mg->mg_len;
685         assert ( mg->mg_ptr != 0 );
686         if (mg->mg_len == HEf_SVKEY)
687            key = SvPV((SV *) mg->mg_ptr, len);
688         SHARED_CONTEXT;
689         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 1);
690     }
691     CALLER_CONTEXT;
692     target = Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
693     sharedsv_scalar_store(aTHX_ sv, target);
694     LEAVE_LOCK;
695     return 0;
696 }
697
698 int
699 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
700 {
701     dTHXc;
702     MAGIC *shmg;
703     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
704     ENTER_LOCK;
705     sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
706     if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
707         sharedsv_scalar_mg_get(aTHX_ sv, shmg);
708     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
709         SHARED_CONTEXT;
710         av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
711     }
712     else {
713         char *key = mg->mg_ptr;
714         STRLEN len = mg->mg_len;
715         assert ( mg->mg_ptr != 0 );
716         if (mg->mg_len == HEf_SVKEY)
717            key = SvPV((SV *) mg->mg_ptr, len);
718         SHARED_CONTEXT;
719         hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD);
720     }
721     CALLER_CONTEXT;
722     LEAVE_LOCK;
723     return 0;
724 }
725
726 int
727 sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
728 {
729     Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj));
730     return 0;
731 }
732
733 int
734 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
735 {
736     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
737     SvREFCNT_inc(SHAREDSvPTR(shared));
738     mg->mg_flags |= MGf_DUP;
739     return 0;
740 }
741
742 MGVTBL sharedsv_elem_vtbl = {
743  sharedsv_elem_mg_FETCH,        /* get */
744  sharedsv_elem_mg_STORE,        /* set */
745  0,                             /* len */
746  sharedsv_elem_mg_DELETE,       /* clear */
747  sharedsv_elem_mg_free,         /* free */
748  0,                             /* copy */
749  sharedsv_elem_mg_dup           /* dup */
750 };
751
752 U32
753 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
754 {
755     dTHXc;
756     shared_sv *shared = (shared_sv *) mg->mg_ptr;
757     U32 val;
758     SHARED_EDIT;
759     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
760         val = av_len((AV*) SHAREDSvPTR(shared));
761     }
762     else {
763         /* not actually defined by tie API but ... */
764         val = HvKEYS((HV*) SHAREDSvPTR(shared));
765     }
766     SHARED_RELEASE;
767     return val;
768 }
769
770 int
771 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
772 {
773     dTHXc;
774     shared_sv *shared = (shared_sv *) mg->mg_ptr;
775     SHARED_EDIT;
776     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
777         av_clear((AV*) SHAREDSvPTR(shared));
778     }
779     else {
780         hv_clear((HV*) SHAREDSvPTR(shared));
781     }
782     SHARED_RELEASE;
783     return 0;
784 }
785
786 int
787 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
788 {
789     Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
790     return 0;
791 }
792
793 /*
794  * This is called when perl is about to access an element of
795  * the array -
796  */
797 int
798 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
799                        SV *nsv, const char *name, int namlen)
800 {
801     shared_sv *shared = (shared_sv *) mg->mg_ptr;
802     MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
803                             toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
804                             name, namlen);
805     ENTER_LOCK;
806     SvREFCNT_inc(SHAREDSvPTR(shared));
807     LEAVE_LOCK;
808     nmg->mg_flags |= MGf_DUP;
809     return 1;
810 }
811
812 int
813 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
814 {
815     shared_sv *shared = (shared_sv *) mg->mg_ptr;
816     SvREFCNT_inc(SHAREDSvPTR(shared));
817     mg->mg_flags |= MGf_DUP;
818     return 0;
819 }
820
821 MGVTBL sharedsv_array_vtbl = {
822  0,                             /* get */
823  0,                             /* set */
824  sharedsv_array_mg_FETCHSIZE,   /* len */
825  sharedsv_array_mg_CLEAR,       /* clear */
826  sharedsv_array_mg_free,        /* free */
827  sharedsv_array_mg_copy,        /* copy */
828  sharedsv_array_mg_dup          /* dup */
829 };
830
831 =for apidoc sharedsv_unlock
832
833 Recursively unlocks a shared sv.
834
835 =cut
836
837 void
838 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
839 {
840     recursive_lock_release(aTHX_ &ssv->lock);
841 }
842
843 =for apidoc sharedsv_lock
844
845 Recursive locks on a sharedsv.
846 Locks are dynamically scoped at the level of the first lock.
847
848 =cut
849
850 void
851 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
852 {
853     if (!ssv)
854         return;
855     recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
856 }
857
858 /* handles calls from lock() builtin via PL_lockhook */
859
860 void
861 Perl_sharedsv_locksv(pTHX_ SV *sv)
862 {
863     shared_sv* shared;
864
865     if(SvROK(sv))
866         sv = SvRV(sv);
867     shared = Perl_sharedsv_find(aTHX_ sv);
868     if(!shared)
869        croak("lock can only be used on shared values");
870     Perl_sharedsv_lock(aTHX_ shared);
871 }
872
873 =head1 Shared SV Functions
874
875 =for apidoc sharedsv_init
876
877 Saves a space for keeping SVs wider than an interpreter,
878
879 =cut
880
881 void
882 Perl_sharedsv_init(pTHX)
883 {
884   dTHXc;
885   /* This pair leaves us in shared context ... */
886   PL_sharedsv_space = perl_alloc();
887   perl_construct(PL_sharedsv_space);
888   CALLER_CONTEXT;
889   recursive_lock_init(aTHX_ &PL_sharedsv_lock);
890   PL_lockhook = &Perl_sharedsv_locksv;
891   PL_sharehook = &Perl_sharedsv_share;
892 }
893
894 #endif /* USE_ITHREADS */
895
896 MODULE = threads::shared        PACKAGE = threads::shared::tie
897
898 PROTOTYPES: DISABLE
899
900 #ifdef USE_ITHREADS
901
902 void
903 PUSH(shared_sv *shared, ...)
904 CODE:
905         dTHXc;
906         int i;
907         for(i = 1; i < items; i++) {
908             SV* tmp = newSVsv(ST(i));
909             shared_sv *target;
910             ENTER_LOCK;
911             target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
912             sharedsv_scalar_store(aTHX_ tmp, target);
913             SHARED_CONTEXT;
914             av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
915             SvREFCNT_inc(SHAREDSvPTR(target));
916             SHARED_RELEASE;
917             SvREFCNT_dec(tmp);
918         }
919
920 void
921 UNSHIFT(shared_sv *shared, ...)
922 CODE:
923         dTHXc;
924         int i;
925         ENTER_LOCK;
926         SHARED_CONTEXT;
927         av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
928         CALLER_CONTEXT;
929         for(i = 1; i < items; i++) {
930             SV* tmp = newSVsv(ST(i));
931             shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
932             sharedsv_scalar_store(aTHX_ tmp, target);
933             SHARED_CONTEXT;
934             av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
935             SvREFCNT_inc(SHAREDSvPTR(target));
936             CALLER_CONTEXT;
937             SvREFCNT_dec(tmp);
938         }
939         LEAVE_LOCK;
940
941 void
942 POP(shared_sv *shared)
943 CODE:
944         dTHXc;
945         SV* sv;
946         ENTER_LOCK;
947         SHARED_CONTEXT;
948         sv = av_pop((AV*)SHAREDSvPTR(shared));
949         CALLER_CONTEXT;
950         ST(0) = sv_newmortal();
951         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
952         SvREFCNT_dec(sv);
953         LEAVE_LOCK;
954         XSRETURN(1);
955
956 void
957 SHIFT(shared_sv *shared)
958 CODE:
959         dTHXc;
960         SV* sv;
961         ENTER_LOCK;
962         SHARED_CONTEXT;
963         sv = av_shift((AV*)SHAREDSvPTR(shared));
964         CALLER_CONTEXT;
965         ST(0) = sv_newmortal();
966         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
967         SvREFCNT_dec(sv);
968         LEAVE_LOCK;
969         XSRETURN(1);
970
971 void
972 EXTEND(shared_sv *shared, IV count)
973 CODE:
974         dTHXc;
975         SHARED_EDIT;
976         av_extend((AV*)SHAREDSvPTR(shared), count);
977         SHARED_RELEASE;
978
979 void
980 STORESIZE(shared_sv *shared,IV count)
981 CODE:
982         dTHXc;
983         SHARED_EDIT;
984         av_fill((AV*) SHAREDSvPTR(shared), count);
985         SHARED_RELEASE;
986
987
988
989
990 void
991 EXISTS(shared_sv *shared, SV *index)
992 CODE:
993         dTHXc;
994         bool exists;
995         if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
996             SHARED_EDIT;
997             exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
998         }
999         else {
1000             STRLEN len;
1001             char *key = SvPV(index,len);
1002             SHARED_EDIT;
1003             exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
1004         }
1005         SHARED_RELEASE;
1006         ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
1007         XSRETURN(1);
1008
1009
1010 void
1011 FIRSTKEY(shared_sv *shared)
1012 CODE:
1013         dTHXc;
1014         char* key = NULL;
1015         I32 len = 0;
1016         HE* entry;
1017         ENTER_LOCK;
1018         SHARED_CONTEXT;
1019         hv_iterinit((HV*) SHAREDSvPTR(shared));
1020         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
1021         if (entry) {
1022                 key = hv_iterkey(entry,&len);
1023                 CALLER_CONTEXT;
1024                 ST(0) = sv_2mortal(newSVpv(key, len));
1025         } else {
1026              CALLER_CONTEXT;
1027              ST(0) = &PL_sv_undef;
1028         }
1029         LEAVE_LOCK;
1030         XSRETURN(1);
1031
1032 void
1033 NEXTKEY(shared_sv *shared, SV *oldkey)
1034 CODE:
1035         dTHXc;
1036         char* key = NULL;
1037         I32 len = 0;
1038         HE* entry;
1039         ENTER_LOCK;
1040         SHARED_CONTEXT;
1041         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
1042         if (entry) {
1043                 key = hv_iterkey(entry,&len);
1044                 CALLER_CONTEXT;
1045                 ST(0) = sv_2mortal(newSVpv(key, len));
1046         } else {
1047              CALLER_CONTEXT;
1048              ST(0) = &PL_sv_undef;
1049         }
1050         LEAVE_LOCK;
1051         XSRETURN(1);
1052
1053 MODULE = threads::shared                PACKAGE = threads::shared
1054
1055 PROTOTYPES: ENABLE
1056
1057 void
1058 _id(SV *ref)
1059         PROTOTYPE: \[$@%]
1060 CODE:
1061         shared_sv *shared;
1062         ref = SvRV(ref);
1063         if(SvROK(ref))
1064             ref = SvRV(ref);
1065         if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
1066             ST(0) = sv_2mortal(newSViv(PTR2IV(shared)));
1067             XSRETURN(1);
1068         }
1069         XSRETURN_UNDEF;
1070
1071
1072 void
1073 _refcnt(SV *ref)
1074         PROTOTYPE: \[$@%]
1075 CODE:
1076         shared_sv *shared;
1077         ref = SvRV(ref);
1078         if(SvROK(ref))
1079             ref = SvRV(ref);
1080         if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
1081           if (SHAREDSvPTR(shared)) {
1082             ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
1083             XSRETURN(1);
1084           }
1085           else {
1086              Perl_warn(aTHX_ "%" SVf " s=%p has no shared SV",ST(0),shared);
1087           }
1088         }
1089         else {
1090              Perl_warn(aTHX_ "%" SVf " is not shared",ST(0));
1091         }
1092         XSRETURN_UNDEF;
1093
1094 SV*
1095 share(SV *ref)
1096         PROTOTYPE: \[$@%]
1097         CODE:
1098         if(!SvROK(ref))
1099             Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
1100         ref = SvRV(ref);
1101         if(SvROK(ref))
1102             ref = SvRV(ref);
1103         Perl_sharedsv_share(aTHX_ ref);
1104         RETVAL = newRV(ref);
1105         OUTPUT:
1106         RETVAL
1107
1108 void
1109 lock_enabled(SV *ref)
1110         PROTOTYPE: \[$@%]
1111         CODE:
1112         shared_sv* shared;
1113         if(!SvROK(ref))
1114             Perl_croak(aTHX_ "Argument to lock needs to be passed as ref");
1115         ref = SvRV(ref);
1116         if(SvROK(ref))
1117             ref = SvRV(ref);
1118         shared = Perl_sharedsv_find(aTHX_ ref);
1119         if(!shared)
1120            croak("lock can only be used on shared values");
1121         Perl_sharedsv_lock(aTHX_ shared);
1122
1123 void
1124 cond_wait_enabled(SV *ref_cond, SV *ref_lock = 0)
1125         PROTOTYPE: \[$@%];\[$@%]
1126         PREINIT:
1127         shared_sv* shared;
1128         perl_cond* user_condition;
1129         int locks;
1130         int same = 0;
1131
1132         CODE:
1133         if (!ref_lock || ref_lock == ref_cond) same = 1;
1134
1135         if(!SvROK(ref_cond))
1136             Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
1137         ref_cond = SvRV(ref_cond);
1138         if(SvROK(ref_cond))
1139             ref_cond = SvRV(ref_cond);
1140         shared = Perl_sharedsv_find(aTHX_ ref_cond);
1141         if(!shared)
1142             croak("cond_wait can only be used on shared values");
1143
1144         user_condition = &shared->user_cond;
1145         if (! same) {
1146             if (!SvROK(ref_lock))
1147                 Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref");
1148             ref_lock = SvRV(ref_lock);
1149             if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1150             shared = Perl_sharedsv_find(aTHX_ ref_lock);
1151             if (!shared)
1152                 croak("cond_wait lock must be a shared value");
1153         }
1154         if(shared->lock.owner != aTHX)
1155             croak("You need a lock before you can cond_wait");
1156         /* Stealing the members of the lock object worries me - NI-S */
1157         MUTEX_LOCK(&shared->lock.mutex);
1158         shared->lock.owner = NULL;
1159         locks = shared->lock.locks;
1160         shared->lock.locks = 0;
1161
1162         /* since we are releasing the lock here we need to tell other
1163         people that is ok to go ahead and use it */
1164         COND_SIGNAL(&shared->lock.cond);
1165         COND_WAIT(user_condition, &shared->lock.mutex);
1166         while(shared->lock.owner != NULL) {
1167             /* OK -- must reacquire the lock */
1168             COND_WAIT(&shared->lock.cond, &shared->lock.mutex);
1169         }
1170         shared->lock.owner = aTHX;
1171         shared->lock.locks = locks;
1172         MUTEX_UNLOCK(&shared->lock.mutex);
1173
1174 int
1175 cond_timedwait_enabled(SV *ref_cond, double abs, SV *ref_lock = 0)
1176         PROTOTYPE: \[$@%]$;\[$@%]
1177         PREINIT:
1178         shared_sv* shared;
1179         perl_cond* user_condition;
1180         int locks;
1181         int same = 0;
1182
1183         CODE:
1184         if (!ref_lock || ref_cond == ref_lock) same = 1;
1185
1186         if(!SvROK(ref_cond))
1187             Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref");
1188         ref_cond = SvRV(ref_cond);
1189         if(SvROK(ref_cond))
1190             ref_cond = SvRV(ref_cond);
1191         shared = Perl_sharedsv_find(aTHX_ ref_cond);
1192         if(!shared)
1193             croak("cond_timedwait can only be used on shared values");
1194     
1195         user_condition = &shared->user_cond;
1196         if (! same) {
1197             if (!SvROK(ref_lock))
1198                 Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref");
1199             ref_lock = SvRV(ref_lock);
1200             if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1201             shared = Perl_sharedsv_find(aTHX_ ref_lock);
1202             if (!shared)
1203                 croak("cond_timedwait lock must be a shared value");
1204         }
1205         if(shared->lock.owner != aTHX)
1206             croak("You need a lock before you can cond_wait");
1207
1208         MUTEX_LOCK(&shared->lock.mutex);
1209         shared->lock.owner = NULL;
1210         locks = shared->lock.locks;
1211         shared->lock.locks = 0;
1212         /* since we are releasing the lock here we need to tell other
1213         people that is ok to go ahead and use it */
1214         COND_SIGNAL(&shared->lock.cond);
1215         RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &shared->lock.mutex, abs);
1216         while (shared->lock.owner != NULL) {
1217             /* OK -- must reacquire the lock... */
1218             COND_WAIT(&shared->lock.cond, &shared->lock.mutex);
1219         }
1220         shared->lock.owner = aTHX;
1221         shared->lock.locks = locks;
1222         MUTEX_UNLOCK(&shared->lock.mutex);
1223
1224         if (RETVAL == 0)
1225             XSRETURN_UNDEF;
1226         OUTPUT:
1227         RETVAL
1228
1229 void
1230 cond_signal_enabled(SV *ref)
1231         PROTOTYPE: \[$@%]
1232         CODE:
1233         shared_sv* shared;
1234         if(!SvROK(ref))
1235             Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
1236         ref = SvRV(ref);
1237         if(SvROK(ref))
1238             ref = SvRV(ref);
1239         shared = Perl_sharedsv_find(aTHX_ ref);
1240         if(!shared)
1241             croak("cond_signal can only be used on shared values");
1242         if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1243             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1244                             "cond_signal() called on unlocked variable");
1245         COND_SIGNAL(&shared->user_cond);
1246
1247 void
1248 cond_broadcast_enabled(SV *ref)
1249         PROTOTYPE: \[$@%]
1250         CODE:
1251         shared_sv* shared;
1252         if(!SvROK(ref))
1253             Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
1254         ref = SvRV(ref);
1255         if(SvROK(ref))
1256             ref = SvRV(ref);
1257         shared = Perl_sharedsv_find(aTHX_ ref);
1258         if(!shared)
1259             croak("cond_broadcast can only be used on shared values");
1260         if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1261             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1262                             "cond_broadcast() called on unlocked variable");
1263         COND_BROADCAST(&shared->user_cond);
1264
1265
1266 SV*
1267 bless(SV* ref, ...);
1268         PROTOTYPE: $;$
1269         CODE:
1270         {
1271           HV* stash;
1272           shared_sv* shared;
1273           if (items == 1)
1274             stash = CopSTASH(PL_curcop);
1275           else {
1276             SV* ssv = ST(1);
1277             STRLEN len;
1278             char *ptr;
1279             
1280             if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
1281               Perl_croak(aTHX_ "Attempt to bless into a reference");
1282             ptr = SvPV(ssv,len);
1283             if (ckWARN(WARN_MISC) && len == 0)
1284               Perl_warner(aTHX_ packWARN(WARN_MISC),
1285                           "Explicit blessing to '' (assuming package main)");
1286             stash = gv_stashpvn(ptr, len, TRUE);
1287           }
1288           SvREFCNT_inc(ref);
1289           (void)sv_bless(ref, stash);
1290           RETVAL = ref;
1291           shared = Perl_sharedsv_find(aTHX_ ref);
1292           if(shared) {
1293             dTHXc;
1294             ENTER_LOCK;
1295             SHARED_CONTEXT;
1296             {
1297               SV* fake_stash = newSVpv(HvNAME(stash),0);
1298               (void)sv_bless(SHAREDSvPTR(shared),(HV*)fake_stash);
1299             }
1300             CALLER_CONTEXT;
1301             LEAVE_LOCK;
1302           }
1303         }
1304         OUTPUT:
1305         RETVAL          
1306
1307 #endif /* USE_ITHREADS */
1308
1309 BOOT:
1310 {
1311 #ifdef USE_ITHREADS
1312      Perl_sharedsv_init(aTHX);
1313 #endif /* USE_ITHREADS */
1314 }
1315
1316
1317