Dump SvUTF8(sv)s also as \x{...}.
[p5sagit/p5-mst-13.2.git] / ext / threads / threads.xs
CommitLineData
47ba8780 1#include "threads.h"
2
47ba8780 3/*
b1edfb69 4 * Starts executing the thread. Needs to clean up memory a tad better.
5 */
47ba8780 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 13 SV* thread_tid_ptr;
14 SV* thread_ptr;
15 dTHXa(thread->interp);
47ba8780 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);
b1edfb69 26 thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread->thr));
27 thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
47ba8780 28 hv_store_ent((HV*)SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
29 SvREFCNT_dec(thread_tid_ptr);
30 SHAREDSvRELEASE(threads);
4f896ddc 31 SHAREDSvUNLOCK(threads);
47ba8780 32 PL_perl_destruct_level = 2;
4f896ddc 33
47ba8780 34 {
35
36 AV* params;
37 I32 len;
38 int i;
39 dSP;
40 params = (AV*) SvRV(thread->params);
41 len = av_len(params);
42 ENTER;
43 SAVETMPS;
44 PUSHMARK(SP);
45 if(len > -1) {
46 for(i = 0; i < len + 1; i++) {
47 XPUSHs(av_shift(params));
48 }
49 }
50 PUTBACK;
4f896ddc 51 call_sv(thread->init_function, G_DISCARD);
47ba8780 52 FREETMPS;
53 LEAVE;
54
55
56 }
57
47ba8780 58 MUTEX_LOCK(&thread->mutex);
59 perl_destruct(thread->interp);
60 perl_free(thread->interp);
61 if(thread->detached == 1) {
62 MUTEX_UNLOCK(&thread->mutex);
e6e315b9 63 Perl_thread_destruct(thread);
47ba8780 64 } else {
65 MUTEX_UNLOCK(&thread->mutex);
66 }
67#ifdef WIN32
68 return (DWORD)0;
e8f2bb9a 69#else
70 return 0;
47ba8780 71#endif
72
73}
74
47ba8780 75/*
b1edfb69 76 * iThread->create();
77 */
47ba8780 78
e6e315b9 79SV* Perl_thread_create(char* class, SV* init_function, SV* params) {
47ba8780 80 ithread* thread = malloc(sizeof(ithread));
81 SV* obj_ref;
82 SV* obj;
83 SV* temp_store;
47ba8780 84 PerlInterpreter *current_perl;
85
86 MUTEX_LOCK(&create_mutex);
87 obj_ref = newSViv(0);
88 obj = newSVrv(obj_ref, class);
b1edfb69 89 sv_setiv(obj, (IV)thread);
90 SvREADONLY_on(obj);
47ba8780 91
b1edfb69 92 current_perl = PERL_GET_CONTEXT;
47ba8780 93
94 /*
b1edfb69 95 * here we put the values of params and function to call onto
96 * namespace, this is so perl will properly clone them when we
97 * call perl_clone.
98 */
4f896ddc 99
b1edfb69 100 temp_store = Perl_get_sv(current_perl, "threads::paramtempstore",
101 TRUE | GV_ADDMULTI);
47ba8780 102 Perl_sv_setsv(current_perl, temp_store,params);
103 params = NULL;
104 temp_store = NULL;
105
b1edfb69 106 temp_store = Perl_get_sv(current_perl, "threads::calltempstore",
107 TRUE | GV_ADDMULTI);
47ba8780 108 Perl_sv_setsv(current_perl,temp_store, init_function);
4f896ddc 109 init_function = NULL;
110 temp_store = NULL;
47ba8780 111
112#ifdef WIN32
b1edfb69 113 thread->interp = perl_clone(current_perl, 4);
47ba8780 114#else
b1edfb69 115 thread->interp = perl_clone(current_perl, 0);
47ba8780 116#endif
47ba8780 117
b1edfb69 118 thread->init_function = newSVsv(Perl_get_sv(thread->interp,
119 "threads::calltempstore",FALSE));
120 thread->params = newSVsv(Perl_get_sv(thread->interp,
121 "threads::paramtempstore",FALSE));
47ba8780 122
123 /*
b1edfb69 124 * And here we make sure we clean up the data we put in the
125 * namespace of iThread, both in the new and the calling
126 * inteprreter */
47ba8780 127
b1edfb69 128 temp_store = Perl_get_sv(thread->interp, "threads::paramtempstore",FALSE);
47ba8780 129 Perl_sv_setsv(thread->interp,temp_store, &PL_sv_undef);
130
131 temp_store = Perl_get_sv(thread->interp,"threads::calltempstore",FALSE);
132 Perl_sv_setsv(thread->interp,temp_store, &PL_sv_undef);
133
134 PERL_SET_CONTEXT(current_perl);
135
136 temp_store = Perl_get_sv(current_perl,"threads::paramtempstore",FALSE);
137 Perl_sv_setsv(current_perl, temp_store, &PL_sv_undef);
138
139 temp_store = Perl_get_sv(current_perl,"threads::calltempstore",FALSE);
140 Perl_sv_setsv(current_perl, temp_store, &PL_sv_undef);
141
b1edfb69 142 /* let's init the thread */
47ba8780 143
144 MUTEX_INIT(&thread->mutex);
145 thread->tid = tid_counter++;
146 thread->detached = 0;
147 thread->count = 1;
148
149#ifdef WIN32
150
e6e315b9 151 thread->handle = CreateThread(NULL, 0, Perl_thread_run,
47ba8780 152 (LPVOID)thread, 0, &thread->thr);
153
154#else
b1edfb69 155 pthread_create( &thread->thr, (pthread_attr_t*)NULL, Perl_thread_run, thread);
47ba8780 156#endif
157 MUTEX_UNLOCK(&create_mutex);
158
b1edfb69 159 return obj_ref;
47ba8780 160}
161
162/*
b1edfb69 163 * returns the id of the thread
164 */
e6e315b9 165I32 Perl_thread_tid (SV* obj) {
47ba8780 166 ithread* thread;
167 if(!SvROK(obj)) {
e6e315b9 168 obj = Perl_thread_self(SvPV_nolen(obj));
47ba8780 169 thread = (ithread*)SvIV(SvRV(obj));
170 SvREFCNT_dec(obj);
171 } else {
172 thread = (ithread*)SvIV(SvRV(obj));
173 }
174 return thread->tid;
175}
176
e6e315b9 177SV* Perl_thread_self (char* class) {
47ba8780 178 dTHX;
179 SV* obj_ref;
180 SV* obj;
b1edfb69 181 SV* thread_tid_ptr;
182 SV* thread_ptr;
183 HE* thread_entry;
47ba8780 184
4f896ddc 185 SHAREDSvLOCK(threads);
47ba8780 186 SHAREDSvEDIT(threads);
187#ifdef WIN32
b1edfb69 188 thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space,
189 (UV) GetCurrentThreadId());
47ba8780 190#else
b1edfb69 191 thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space,
192 PTR2UV(pthread_self()));
47ba8780 193#endif
b1edfb69 194 thread_entry = Perl_hv_fetch_ent(PL_sharedsv_space,
195 (HV*) SHAREDSvGET(threads),
196 thread_tid_ptr, 0,0);
47ba8780 197 thread_ptr = HeVAL(thread_entry);
198 SvREFCNT_dec(thread_tid_ptr);
47ba8780 199 SHAREDSvRELEASE(threads);
4f896ddc 200 SHAREDSvUNLOCK(threads);
47ba8780 201
202 obj_ref = newSViv(0);
203 obj = newSVrv(obj_ref, class);
4f896ddc 204 sv_setsv(obj, thread_ptr);
47ba8780 205 SvREADONLY_on(obj);
206 return obj_ref;
207}
208
209/*
b1edfb69 210 * joins the thread this code needs to take the returnvalue from the
211 * call_sv and send it back */
47ba8780 212
e6e315b9 213void Perl_thread_join(SV* obj) {
47ba8780 214 ithread* thread = (ithread*)SvIV(SvRV(obj));
215#ifdef WIN32
216 DWORD waitcode;
217 waitcode = WaitForSingleObject(thread->handle, INFINITE);
218#else
219 void *retval;
220 pthread_join(thread->thr,&retval);
221#endif
222}
223
b1edfb69 224/* detaches a thread
225 * needs to better clean up memory */
47ba8780 226
e6e315b9 227void Perl_thread_detach(SV* obj) {
47ba8780 228 ithread* thread = (ithread*)SvIV(SvRV(obj));
229 MUTEX_LOCK(&thread->mutex);
230 thread->detached = 1;
231#if !defined(WIN32)
232 pthread_detach(thread->thr);
233#endif
234 MUTEX_UNLOCK(&thread->mutex);
235}
236
e6e315b9 237void Perl_thread_DESTROY (SV* obj) {
47ba8780 238 ithread* thread = (ithread*)SvIV(SvRV(obj));
239
240 MUTEX_LOCK(&thread->mutex);
241 thread->count--;
242 MUTEX_UNLOCK(&thread->mutex);
e6e315b9 243 Perl_thread_destruct(thread);
47ba8780 244}
245
e6e315b9 246void Perl_thread_destruct (ithread* thread) {
47ba8780 247 return;
248 MUTEX_LOCK(&thread->mutex);
249 if(thread->count != 0) {
250 MUTEX_UNLOCK(&thread->mutex);
251 return;
252 }
253 MUTEX_UNLOCK(&thread->mutex);
254 /* it is safe noone is holding a ref to this */
255 /*printf("proper destruction!\n");*/
256}
257
47ba8780 258MODULE = threads PACKAGE = threads
259BOOT:
260 Perl_sharedsv_init(aTHX);
261 PL_perl_destruct_level = 2;
262 threads = Perl_sharedsv_new(aTHX);
263 SHAREDSvEDIT(threads);
e8f2bb9a 264 SHAREDSvGET(threads) = (SV *)newHV();
47ba8780 265 SHAREDSvRELEASE(threads);
266 {
267
268
269 SV* temp = get_sv("threads::sharedsv_space", TRUE | GV_ADDMULTI);
4f896ddc 270 SV* temp2 = newSViv((IV)PL_sharedsv_space );
47ba8780 271 sv_setsv( temp , temp2 );
272 }
273 {
274 ithread* thread = malloc(sizeof(ithread));
275 SV* thread_tid_ptr;
276 SV* thread_ptr;
277 MUTEX_INIT(&thread->mutex);
278 thread->tid = 0;
279#ifdef WIN32
280 thread->thr = GetCurrentThreadId();
281#else
282 thread->thr = pthread_self();
283#endif
d5ecd109 284 SHAREDSvEDIT(threads);
b1edfb69 285 thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread->thr));
286 thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
47ba8780 287 hv_store_ent((HV*) SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
4f896ddc 288 SvREFCNT_dec(thread_tid_ptr);
d5ecd109 289 SHAREDSvRELEASE(threads);
47ba8780 290 }
291 MUTEX_INIT(&create_mutex);
292
47ba8780 293PROTOTYPES: DISABLE
294
295SV *
296create (class, function_to_call, ...)
297 char * class
298 SV * function_to_call
299 CODE:
300 AV* params = newAV();
301 if(items > 2) {
302 int i;
303 for(i = 2; i < items ; i++) {
304 av_push(params, ST(i));
305 }
306 }
e6e315b9 307 RETVAL = Perl_thread_create(class, function_to_call, newRV_noinc((SV*) params));
47ba8780 308 OUTPUT:
309 RETVAL
310
311SV *
312self (class)
313 char* class
314 CODE:
e6e315b9 315 RETVAL = Perl_thread_self(class);
47ba8780 316 OUTPUT:
317 RETVAL
318
319int
320tid (obj)
321 SV * obj;
322 CODE:
e6e315b9 323 RETVAL = Perl_thread_tid(obj);
47ba8780 324 OUTPUT:
325 RETVAL
326
327void
328join (obj)
329 SV * obj
330 PREINIT:
331 I32* temp;
332 PPCODE:
333 temp = PL_markstack_ptr++;
e6e315b9 334 Perl_thread_join(obj);
47ba8780 335 if (PL_markstack_ptr != temp) {
336 /* truly void, because dXSARGS not invoked */
337 PL_markstack_ptr = temp;
338 XSRETURN_EMPTY; /* return empty stack */
339 }
340 /* must have used dXSARGS; list context implied */
341 return; /* assume stack size is correct */
342
343void
344detach (obj)
345 SV * obj
346 PREINIT:
347 I32* temp;
348 PPCODE:
349 temp = PL_markstack_ptr++;
e6e315b9 350 Perl_thread_detach(obj);
47ba8780 351 if (PL_markstack_ptr != temp) {
352 /* truly void, because dXSARGS not invoked */
353 PL_markstack_ptr = temp;
354 XSRETURN_EMPTY; /* return empty stack */
355 }
356 /* must have used dXSARGS; list context implied */
357 return; /* assume stack size is correct */
358
47ba8780 359void
360DESTROY (obj)
361 SV * obj
362 PREINIT:
363 I32* temp;
364 PPCODE:
365 temp = PL_markstack_ptr++;
e6e315b9 366 Perl_thread_DESTROY(obj);
47ba8780 367 if (PL_markstack_ptr != temp) {
368 /* truly void, because dXSARGS not invoked */
369 PL_markstack_ptr = temp;
370 XSRETURN_EMPTY; /* return empty stack */
371 }
372 /* must have used dXSARGS; list context implied */
373 return; /* assume stack size is correct */
374