This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] Smoke 12057 /pro/3gl/CPAN/perl-current
[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
132// sv_dump(SvRV(Perl_get_sv(current_perl, "threads::calltempstore",FALSE)));
133// sv_dump(SvRV(Perl_get_sv(thread->interp, "threads::calltempstore",FALSE)));
134
135 thread->init_function = newSVsv(Perl_get_sv(thread->interp, "threads::calltempstore",FALSE));
136 thread->params = newSVsv(Perl_get_sv(thread->interp, "threads::paramtempstore",FALSE));
137
138 init_function = NULL;
139 temp_store = NULL;
140
141
142 /*
143 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
144 */
145
146
147
148 temp_store = Perl_get_sv(thread->interp,"threads::paramtempstore",FALSE);
149 Perl_sv_setsv(thread->interp,temp_store, &PL_sv_undef);
150
151 temp_store = Perl_get_sv(thread->interp,"threads::calltempstore",FALSE);
152 Perl_sv_setsv(thread->interp,temp_store, &PL_sv_undef);
153
154 PERL_SET_CONTEXT(current_perl);
155
156 temp_store = Perl_get_sv(current_perl,"threads::paramtempstore",FALSE);
157 Perl_sv_setsv(current_perl, temp_store, &PL_sv_undef);
158
159 temp_store = Perl_get_sv(current_perl,"threads::calltempstore",FALSE);
160 Perl_sv_setsv(current_perl, temp_store, &PL_sv_undef);
161
162 /* lets init the thread */
163
164
165
166
167
168 MUTEX_INIT(&thread->mutex);
169 thread->tid = tid_counter++;
170 thread->detached = 0;
171 thread->count = 1;
172
173#ifdef WIN32
174
175 thread->handle = CreateThread(NULL, 0, thread_run,
176 (LPVOID)thread, 0, &thread->thr);
177
178#else
179 pthread_create( &thread->thr, NULL, (void *) thread_run, thread);
180#endif
181 MUTEX_UNLOCK(&create_mutex);
182
183
184 if(!SvRV(obj_ref)) printf("FUCK\n");
185 return obj_ref;
186}
187
188/*
189 returns the id of the thread
190*/
191I32 thread_tid (SV* obj) {
192 ithread* thread;
193 if(!SvROK(obj)) {
194 obj = thread_self(SvPV_nolen(obj));
195 thread = (ithread*)SvIV(SvRV(obj));
196 SvREFCNT_dec(obj);
197 } else {
198 thread = (ithread*)SvIV(SvRV(obj));
199 }
200 return thread->tid;
201}
202
203SV* thread_self (char* class) {
204 dTHX;
205 SV* obj_ref;
206 SV* obj;
207 SV* thread_tid_ptr;
208 SV* thread_ptr;
209 HE* thread_entry;
210 IV pointer;
211 PerlInterpreter *old_context = PERL_GET_CONTEXT;
212
213
214
215 SHAREDSvEDIT(threads);
216#ifdef WIN32
217 thread_tid_ptr = Perl_newSViv(sharedsv_space, (IV) GetCurrentThreadId());
218#else
219 thread_tid_ptr = Perl_newSViv(sharedsv_space, (IV) pthread_self());
220#endif
221 thread_entry = Perl_hv_fetch_ent(sharedsv_space,(HV*) SHAREDSvGET(threads), thread_tid_ptr, 0,0);
222 thread_ptr = HeVAL(thread_entry);
223 SvREFCNT_dec(thread_tid_ptr);
224 pointer = SvIV(thread_ptr);
225 SHAREDSvRELEASE(threads);
226
227
228
229
230 obj_ref = newSViv(0);
231 obj = newSVrv(obj_ref, class);
232 sv_setiv(obj, pointer);
233 SvREADONLY_on(obj);
234 return obj_ref;
235}
236
237/*
238 joins the thread
239 this code needs to take the returnvalue from the call_sv and send it back
240*/
241
242void thread_join(SV* obj) {
243 ithread* thread = (ithread*)SvIV(SvRV(obj));
244#ifdef WIN32
245 DWORD waitcode;
246 waitcode = WaitForSingleObject(thread->handle, INFINITE);
247#else
248 void *retval;
249 pthread_join(thread->thr,&retval);
250#endif
251}
252
253
254/*
255 detaches a thread
256 needs to better clean up memory
257*/
258
259void thread_detach(SV* obj) {
260 ithread* thread = (ithread*)SvIV(SvRV(obj));
261 MUTEX_LOCK(&thread->mutex);
262 thread->detached = 1;
263#if !defined(WIN32)
264 pthread_detach(thread->thr);
265#endif
266 MUTEX_UNLOCK(&thread->mutex);
267}
268
269
270
271void thread_DESTROY (SV* obj) {
272 ithread* thread = (ithread*)SvIV(SvRV(obj));
273
274 MUTEX_LOCK(&thread->mutex);
275 thread->count--;
276 MUTEX_UNLOCK(&thread->mutex);
277 thread_destruct(thread);
278
279}
280
281void thread_destruct (ithread* thread) {
282 return;
283 MUTEX_LOCK(&thread->mutex);
284 if(thread->count != 0) {
285 MUTEX_UNLOCK(&thread->mutex);
286 return;
287 }
288 MUTEX_UNLOCK(&thread->mutex);
289 /* it is safe noone is holding a ref to this */
290 /*printf("proper destruction!\n");*/
291}
292
293
294MODULE = threads PACKAGE = threads
295BOOT:
296 Perl_sharedsv_init(aTHX);
297 PL_perl_destruct_level = 2;
298 threads = Perl_sharedsv_new(aTHX);
299 SHAREDSvEDIT(threads);
a86deb9a 300 SHAREDSvGET(threads) = (SV *)newHV();
47ba8780
AB
301 SHAREDSvRELEASE(threads);
302 {
303
304
305 SV* temp = get_sv("threads::sharedsv_space", TRUE | GV_ADDMULTI);
306 SV* temp2 = newSViv((IV)sharedsv_space );
307 sv_setsv( temp , temp2 );
308 }
309 {
310 ithread* thread = malloc(sizeof(ithread));
311 SV* thread_tid_ptr;
312 SV* thread_ptr;
313 MUTEX_INIT(&thread->mutex);
314 thread->tid = 0;
315#ifdef WIN32
316 thread->thr = GetCurrentThreadId();
317#else
318 thread->thr = pthread_self();
319#endif
320 SHAREDSvEDIT(threads);
321 thread_tid_ptr = Perl_newSViv(sharedsv_space, (IV) thread->thr);
322 thread_ptr = Perl_newSViv(sharedsv_space, (IV) thread);
323 hv_store_ent((HV*) SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
324 SvREFCNT_dec(thread_tid_ptr);
325 SHAREDSvRELEASE(threads);
326
327 }
328 MUTEX_INIT(&create_mutex);
329
330
331
332PROTOTYPES: DISABLE
333
334SV *
335create (class, function_to_call, ...)
336 char * class
337 SV * function_to_call
338 CODE:
339 AV* params = newAV();
340 if(items > 2) {
341 int i;
342 for(i = 2; i < items ; i++) {
343 av_push(params, ST(i));
344 }
345 }
346 RETVAL = thread_create(class, function_to_call, newRV_noinc((SV*) params));
347 OUTPUT:
348 RETVAL
349
350SV *
351self (class)
352 char* class
353 CODE:
354 RETVAL = thread_self(class);
355 OUTPUT:
356 RETVAL
357
358int
359tid (obj)
360 SV * obj;
361 CODE:
362 RETVAL = thread_tid(obj);
363 OUTPUT:
364 RETVAL
365
366void
367join (obj)
368 SV * obj
369 PREINIT:
370 I32* temp;
371 PPCODE:
372 temp = PL_markstack_ptr++;
373 thread_join(obj);
374 if (PL_markstack_ptr != temp) {
375 /* truly void, because dXSARGS not invoked */
376 PL_markstack_ptr = temp;
377 XSRETURN_EMPTY; /* return empty stack */
378 }
379 /* must have used dXSARGS; list context implied */
380 return; /* assume stack size is correct */
381
382void
383detach (obj)
384 SV * obj
385 PREINIT:
386 I32* temp;
387 PPCODE:
388 temp = PL_markstack_ptr++;
389 thread_detach(obj);
390 if (PL_markstack_ptr != temp) {
391 /* truly void, because dXSARGS not invoked */
392 PL_markstack_ptr = temp;
393 XSRETURN_EMPTY; /* return empty stack */
394 }
395 /* must have used dXSARGS; list context implied */
396 return; /* assume stack size is correct */
397
398
399
400
401
402void
403DESTROY (obj)
404 SV * obj
405 PREINIT:
406 I32* temp;
407 PPCODE:
408 temp = PL_markstack_ptr++;
409 thread_DESTROY(obj);
410 if (PL_markstack_ptr != temp) {
411 /* truly void, because dXSARGS not invoked */
412 PL_markstack_ptr = temp;
413 XSRETURN_EMPTY; /* return empty stack */
414 }
415 /* must have used dXSARGS; list context implied */
416 return; /* assume stack size is correct */
417
418
419