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