This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Split out core of sv_magic() into sv_magicext().
[perl5.git] / ext / threads / threads.xs
CommitLineData
47ba8780
AB
1#include "threads.h"
2
47ba8780 3/*
b1edfb69
JH
4 * Starts executing the thread. Needs to clean up memory a tad better.
5 */
47ba8780
AB
6
7#ifdef WIN32
e6e315b9 8THREAD_RET_TYPE Perl_thread_run(LPVOID arg) {
47ba8780 9#else
e8f2bb9a 10void* Perl_thread_run(void * arg) {
47ba8780 11#endif
5b414d21 12 ithread* thread = (ithread*) arg;
47ba8780
AB
13 SV* thread_tid_ptr;
14 SV* thread_ptr;
15 dTHXa(thread->interp);
47ba8780
AB
16 PERL_SET_CONTEXT(thread->interp);
17
18#ifdef WIN32
19 thread->thr = GetCurrentThreadId();
20#else
21 thread->thr = pthread_self();
22#endif
23
4f896ddc 24 SHAREDSvLOCK(threads);
47ba8780 25 SHAREDSvEDIT(threads);
7f9a95ef
AB
26 PERL_THREAD_SETSPECIFIC(self_key,INT2PTR(void*,thread->tid));
27 thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, thread->tid);
b1edfb69 28 thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
47ba8780
AB
29 hv_store_ent((HV*)SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
30 SvREFCNT_dec(thread_tid_ptr);
31 SHAREDSvRELEASE(threads);
4f896ddc 32 SHAREDSvUNLOCK(threads);
47ba8780 33 PL_perl_destruct_level = 2;
4f896ddc 34
47ba8780
AB
35 {
36
37 AV* params;
38 I32 len;
39 int i;
40 dSP;
41 params = (AV*) SvRV(thread->params);
42 len = av_len(params);
43 ENTER;
44 SAVETMPS;
45 PUSHMARK(SP);
46 if(len > -1) {
47 for(i = 0; i < len + 1; i++) {
48 XPUSHs(av_shift(params));
49 }
50 }
51 PUTBACK;
4f896ddc 52 call_sv(thread->init_function, G_DISCARD);
47ba8780
AB
53 FREETMPS;
54 LEAVE;
55
56
57 }
58
47ba8780 59 MUTEX_LOCK(&thread->mutex);
fd58862f 60 PerlIO_flush((PerlIO*)NULL);
47ba8780
AB
61 perl_destruct(thread->interp);
62 perl_free(thread->interp);
63 if(thread->detached == 1) {
64 MUTEX_UNLOCK(&thread->mutex);
e6e315b9 65 Perl_thread_destruct(thread);
47ba8780
AB
66 } else {
67 MUTEX_UNLOCK(&thread->mutex);
68 }
69#ifdef WIN32
70 return (DWORD)0;
e8f2bb9a
JH
71#else
72 return 0;
47ba8780
AB
73#endif
74
75}
76
47ba8780 77/*
b1edfb69
JH
78 * iThread->create();
79 */
47ba8780 80
e6e315b9 81SV* Perl_thread_create(char* class, SV* init_function, SV* params) {
47ba8780
AB
82 ithread* thread = malloc(sizeof(ithread));
83 SV* obj_ref;
84 SV* obj;
85 SV* temp_store;
47ba8780 86 PerlInterpreter *current_perl;
b50cb5ff 87 CLONE_PARAMS clone_param;
47ba8780
AB
88
89 MUTEX_LOCK(&create_mutex);
90 obj_ref = newSViv(0);
91 obj = newSVrv(obj_ref, class);
170958c3 92 sv_setiv(obj, PTR2IV(thread));
b1edfb69 93 SvREADONLY_on(obj);
b6a0b930 94 PerlIO_flush((PerlIO*)NULL);
b1edfb69 95 current_perl = PERL_GET_CONTEXT;
47ba8780 96
4f896ddc 97
47ba8780 98
cd8c9bf8 99 temp_store = Perl_get_sv(current_perl, "threads::origthread", TRUE | GV_ADDMULTI);
170958c3 100 sv_setiv(temp_store,PTR2IV(current_perl));
cd8c9bf8
AB
101 temp_store = NULL;
102
103
47ba8780 104#ifdef WIN32
b50cb5ff 105 thread->interp = perl_clone(current_perl, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
47ba8780 106#else
b50cb5ff 107 thread->interp = perl_clone(current_perl, CLONEf_KEEP_PTR_TABLE);
47ba8780 108#endif
b50cb5ff 109
47ba8780 110
b50cb5ff
AB
111 clone_param.flags = 0;
112 thread->init_function = Perl_sv_dup(thread->interp, init_function, &clone_param);
113 if(SvREFCNT(thread->init_function) == 0) {
114 SvREFCNT_inc(thread->init_function);
115 }
116
117 thread->params = Perl_sv_dup(thread->interp,params, &clone_param);
118 SvREFCNT_inc(thread->params);
119 SvTEMP_off(thread->init_function);
120 ptr_table_free(PL_ptr_table);
121 PL_ptr_table = NULL;
122
47ba8780 123
47ba8780 124
47ba8780
AB
125
126 PERL_SET_CONTEXT(current_perl);
127
47ba8780 128
b1edfb69 129 /* let's init the thread */
47ba8780
AB
130
131 MUTEX_INIT(&thread->mutex);
132 thread->tid = tid_counter++;
133 thread->detached = 0;
134 thread->count = 1;
135
136#ifdef WIN32
137
e6e315b9 138 thread->handle = CreateThread(NULL, 0, Perl_thread_run,
47ba8780
AB
139 (LPVOID)thread, 0, &thread->thr);
140
82c40bf6
AB
141
142#else
fa26028c
AB
143 {
144 static pthread_attr_t attr;
145 static int attr_inited = 0;
146 sigset_t fullmask, oldmask;
147 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
148 if (!attr_inited) {
149 attr_inited = 1;
150 pthread_attr_init(&attr);
151 }
152# ifdef PTHREAD_ATTR_SETDETACHSTATE
153 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
154# endif
3eb37d38
AB
155# ifdef THREAD_CREATE_NEEDS_STACK
156 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
157 croak("panic: pthread_attr_setstacksize failed");
158# endif
159
3ad0b7d6 160#ifdef OLD_PTHREADS_API
fa26028c 161 pthread_create( &thread->thr, attr, Perl_thread_run, (void *)thread);
47ba8780 162#else
3ad0b7d6 163 pthread_create( &thread->thr, &attr, Perl_thread_run, (void *)thread);
47ba8780 164#endif
3ad0b7d6 165 }
82c40bf6 166#endif
47ba8780
AB
167 MUTEX_UNLOCK(&create_mutex);
168
b1edfb69 169 return obj_ref;
47ba8780
AB
170}
171
172/*
b1edfb69
JH
173 * returns the id of the thread
174 */
e6e315b9 175I32 Perl_thread_tid (SV* obj) {
47ba8780
AB
176 ithread* thread;
177 if(!SvROK(obj)) {
e6e315b9 178 obj = Perl_thread_self(SvPV_nolen(obj));
170958c3 179 thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
47ba8780
AB
180 SvREFCNT_dec(obj);
181 } else {
170958c3 182 thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
47ba8780
AB
183 }
184 return thread->tid;
185}
186
e6e315b9 187SV* Perl_thread_self (char* class) {
47ba8780
AB
188 dTHX;
189 SV* obj_ref;
190 SV* obj;
b1edfb69
JH
191 SV* thread_tid_ptr;
192 SV* thread_ptr;
193 HE* thread_entry;
7f9a95ef
AB
194 void* id;
195 PERL_THREAD_GETSPECIFIC(self_key,id);
4f896ddc 196 SHAREDSvLOCK(threads);
47ba8780 197 SHAREDSvEDIT(threads);
7f9a95ef
AB
198
199 thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(id));
82c40bf6 200
b1edfb69
JH
201 thread_entry = Perl_hv_fetch_ent(PL_sharedsv_space,
202 (HV*) SHAREDSvGET(threads),
203 thread_tid_ptr, 0,0);
47ba8780
AB
204 thread_ptr = HeVAL(thread_entry);
205 SvREFCNT_dec(thread_tid_ptr);
47ba8780 206 SHAREDSvRELEASE(threads);
4f896ddc 207 SHAREDSvUNLOCK(threads);
47ba8780
AB
208
209 obj_ref = newSViv(0);
210 obj = newSVrv(obj_ref, class);
4f896ddc 211 sv_setsv(obj, thread_ptr);
47ba8780
AB
212 SvREADONLY_on(obj);
213 return obj_ref;
214}
215
216/*
b1edfb69
JH
217 * joins the thread this code needs to take the returnvalue from the
218 * call_sv and send it back */
47ba8780 219
e6e315b9 220void Perl_thread_join(SV* obj) {
170958c3 221 ithread* thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
47ba8780
AB
222#ifdef WIN32
223 DWORD waitcode;
224 waitcode = WaitForSingleObject(thread->handle, INFINITE);
225#else
226 void *retval;
227 pthread_join(thread->thr,&retval);
228#endif
229}
230
b1edfb69
JH
231/* detaches a thread
232 * needs to better clean up memory */
47ba8780 233
e6e315b9 234void Perl_thread_detach(SV* obj) {
170958c3 235 ithread* thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
47ba8780
AB
236 MUTEX_LOCK(&thread->mutex);
237 thread->detached = 1;
82c40bf6 238 PERL_THREAD_DETACH(thread->thr);
47ba8780
AB
239 MUTEX_UNLOCK(&thread->mutex);
240}
241
e6e315b9 242void Perl_thread_DESTROY (SV* obj) {
170958c3 243 ithread* thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
47ba8780
AB
244
245 MUTEX_LOCK(&thread->mutex);
246 thread->count--;
247 MUTEX_UNLOCK(&thread->mutex);
e6e315b9 248 Perl_thread_destruct(thread);
47ba8780
AB
249}
250
e6e315b9 251void Perl_thread_destruct (ithread* thread) {
47ba8780
AB
252 return;
253 MUTEX_LOCK(&thread->mutex);
254 if(thread->count != 0) {
255 MUTEX_UNLOCK(&thread->mutex);
256 return;
257 }
258 MUTEX_UNLOCK(&thread->mutex);
259 /* it is safe noone is holding a ref to this */
260 /*printf("proper destruction!\n");*/
261}
262
47ba8780
AB
263MODULE = threads PACKAGE = threads
264BOOT:
265 Perl_sharedsv_init(aTHX);
89e0305a 266 PERL_THREAD_ALLOC_SPECIFIC(self_key);
47ba8780
AB
267 PL_perl_destruct_level = 2;
268 threads = Perl_sharedsv_new(aTHX);
269 SHAREDSvEDIT(threads);
e8f2bb9a 270 SHAREDSvGET(threads) = (SV *)newHV();
47ba8780
AB
271 SHAREDSvRELEASE(threads);
272 {
273
274
275 SV* temp = get_sv("threads::sharedsv_space", TRUE | GV_ADDMULTI);
170958c3 276 SV* temp2 = newSViv(PTR2IV(PL_sharedsv_space));
47ba8780
AB
277 sv_setsv( temp , temp2 );
278 }
279 {
280 ithread* thread = malloc(sizeof(ithread));
281 SV* thread_tid_ptr;
282 SV* thread_ptr;
283 MUTEX_INIT(&thread->mutex);
284 thread->tid = 0;
285#ifdef WIN32
286 thread->thr = GetCurrentThreadId();
287#else
288 thread->thr = pthread_self();
289#endif
d5ecd109 290 SHAREDSvEDIT(threads);
82c40bf6 291 PERL_THREAD_ALLOC_SPECIFIC(self_key);
7f9a95ef
AB
292 PERL_THREAD_SETSPECIFIC(self_key,0);
293 thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, 0);
b1edfb69 294 thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
47ba8780 295 hv_store_ent((HV*) SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
4f896ddc 296 SvREFCNT_dec(thread_tid_ptr);
d5ecd109 297 SHAREDSvRELEASE(threads);
47ba8780
AB
298 }
299 MUTEX_INIT(&create_mutex);
300
47ba8780
AB
301PROTOTYPES: DISABLE
302
303SV *
304create (class, function_to_call, ...)
305 char * class
306 SV * function_to_call
307 CODE:
308 AV* params = newAV();
309 if(items > 2) {
310 int i;
311 for(i = 2; i < items ; i++) {
312 av_push(params, ST(i));
313 }
314 }
e6e315b9 315 RETVAL = Perl_thread_create(class, function_to_call, newRV_noinc((SV*) params));
47ba8780
AB
316 OUTPUT:
317 RETVAL
318
319SV *
8222d950
AB
320new (class, function_to_call, ...)
321 char * class
322 SV * function_to_call
323 CODE:
324 AV* params = newAV();
325 if(items > 2) {
326 int i;
327 for(i = 2; i < items ; i++) {
328 av_push(params, ST(i));
329 }
330 }
331 RETVAL = Perl_thread_create(class, function_to_call, newRV_noinc((SV*) params));
332 OUTPUT:
333 RETVAL
334
335
336
337SV *
47ba8780
AB
338self (class)
339 char* class
340 CODE:
e6e315b9 341 RETVAL = Perl_thread_self(class);
47ba8780
AB
342 OUTPUT:
343 RETVAL
344
345int
346tid (obj)
347 SV * obj;
348 CODE:
e6e315b9 349 RETVAL = Perl_thread_tid(obj);
47ba8780
AB
350 OUTPUT:
351 RETVAL
352
353void
354join (obj)
355 SV * obj
356 PREINIT:
357 I32* temp;
358 PPCODE:
359 temp = PL_markstack_ptr++;
e6e315b9 360 Perl_thread_join(obj);
47ba8780
AB
361 if (PL_markstack_ptr != temp) {
362 /* truly void, because dXSARGS not invoked */
363 PL_markstack_ptr = temp;
364 XSRETURN_EMPTY; /* return empty stack */
365 }
366 /* must have used dXSARGS; list context implied */
367 return; /* assume stack size is correct */
368
369void
370detach (obj)
371 SV * obj
372 PREINIT:
373 I32* temp;
374 PPCODE:
375 temp = PL_markstack_ptr++;
e6e315b9 376 Perl_thread_detach(obj);
47ba8780
AB
377 if (PL_markstack_ptr != temp) {
378 /* truly void, because dXSARGS not invoked */
379 PL_markstack_ptr = temp;
380 XSRETURN_EMPTY; /* return empty stack */
381 }
382 /* must have used dXSARGS; list context implied */
383 return; /* assume stack size is correct */
384
47ba8780
AB
385void
386DESTROY (obj)
387 SV * obj
388 PREINIT:
389 I32* temp;
390 PPCODE:
391 temp = PL_markstack_ptr++;
e6e315b9 392 Perl_thread_DESTROY(obj);
47ba8780
AB
393 if (PL_markstack_ptr != temp) {
394 /* truly void, because dXSARGS not invoked */
395 PL_markstack_ptr = temp;
396 XSRETURN_EMPTY; /* return empty stack */
397 }
398 /* must have used dXSARGS; list context implied */
399 return; /* assume stack size is correct */
400