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