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