This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
6f58de968180358079dc3403f9ce47f5aa7ffea4
[perl5.git] / ext / threads / threads.xs
1 #include "threads.h"
2
3 /*
4  *      Starts executing the thread. Needs to clean up memory a tad better.
5  */
6
7 #ifdef WIN32
8 THREAD_RET_TYPE Perl_thread_run(LPVOID arg) {
9 #else
10 void* Perl_thread_run(void * arg) {
11 #endif
12         ithread* thread = (ithread*) arg;
13         SV* thread_tid_ptr;
14         SV* thread_ptr;
15         dTHXa(thread->interp);
16         PERL_SET_CONTEXT(thread->interp);
17
18 #ifdef WIN32
19         thread->thr = GetCurrentThreadId();
20 #else
21         thread->thr = pthread_self();
22 #endif
23
24         SHAREDSvLOCK(threads);
25         SHAREDSvEDIT(threads);
26         PERL_THREAD_SETSPECIFIC(self_key,INT2PTR(void*,thread->tid));
27         thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, thread->tid);  
28         thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
29         hv_store_ent((HV*)SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
30         SvREFCNT_dec(thread_tid_ptr);
31         SHAREDSvRELEASE(threads);
32         SHAREDSvUNLOCK(threads);
33         PL_perl_destruct_level = 2;
34
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;
52                 call_sv(thread->init_function, G_DISCARD);
53                 FREETMPS;
54                 LEAVE;
55
56
57         }
58
59         MUTEX_LOCK(&thread->mutex);
60         PerlIO_flush((PerlIO*)NULL);
61         perl_destruct(thread->interp);  
62         perl_free(thread->interp);
63         if(thread->detached == 1) {
64                 MUTEX_UNLOCK(&thread->mutex);
65                 Perl_thread_destruct(thread);
66         } else {
67                 MUTEX_UNLOCK(&thread->mutex);
68         }
69 #ifdef WIN32
70         return (DWORD)0;
71 #else
72         return 0;
73 #endif
74
75 }
76
77 /*
78  * iThread->create();
79  */
80
81 SV* Perl_thread_create(char* class, SV* init_function, SV* params) {
82         ithread* thread = malloc(sizeof(ithread));
83         SV*      obj_ref;
84         SV*      obj;
85         SV*             temp_store;
86         PerlInterpreter *current_perl;
87         CLONE_PARAMS clone_param;
88
89         MUTEX_LOCK(&create_mutex);  
90         obj_ref = newSViv(0);
91         obj = newSVrv(obj_ref, class);
92         sv_setiv(obj, PTR2IV(thread));
93         SvREADONLY_on(obj);
94         PerlIO_flush((PerlIO*)NULL);
95         current_perl = PERL_GET_CONTEXT;        
96
97
98
99         temp_store = Perl_get_sv(current_perl, "threads::origthread", TRUE | GV_ADDMULTI);
100         sv_setiv(temp_store,PTR2IV(current_perl));
101         temp_store = NULL;      
102
103         
104 #ifdef WIN32
105         thread->interp = perl_clone(current_perl, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
106 #else
107         thread->interp = perl_clone(current_perl, CLONEf_KEEP_PTR_TABLE);
108 #endif
109         
110
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         
123
124
125
126         PERL_SET_CONTEXT(current_perl);
127
128
129         /* let's init the thread */
130
131         MUTEX_INIT(&thread->mutex);
132         thread->tid = tid_counter++;
133         thread->detached = 0;
134         thread->count = 1;
135
136 #ifdef WIN32
137
138         thread->handle = CreateThread(NULL, 0, Perl_thread_run,
139                         (LPVOID)thread, 0, &thread->thr);
140
141
142 #else
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
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
160 #ifdef OLD_PTHREADS_API
161           pthread_create( &thread->thr, attr, Perl_thread_run, (void *)thread);
162 #else
163           pthread_create( &thread->thr, &attr, Perl_thread_run, (void *)thread);
164 #endif
165         }
166 #endif
167         MUTEX_UNLOCK(&create_mutex);    
168
169         return obj_ref;
170 }
171
172 /*
173  * returns the id of the thread
174  */
175 I32 Perl_thread_tid (SV* obj) {
176         ithread* thread;
177         if(!SvROK(obj)) {
178                 obj = Perl_thread_self(SvPV_nolen(obj));
179                 thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
180                 SvREFCNT_dec(obj);
181         } else {
182                 thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
183         }
184         return thread->tid;
185 }
186
187 SV* Perl_thread_self (char* class) {
188         dTHX;
189         SV*      obj_ref;
190         SV*      obj;
191         SV*     thread_tid_ptr;
192         SV*     thread_ptr;
193         HE*     thread_entry;
194         void*   id;
195         PERL_THREAD_GETSPECIFIC(self_key,id);
196         SHAREDSvLOCK(threads);
197         SHAREDSvEDIT(threads);
198         
199         thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(id));   
200
201         thread_entry = Perl_hv_fetch_ent(PL_sharedsv_space,
202                                          (HV*) SHAREDSvGET(threads),
203                                          thread_tid_ptr, 0,0);
204         thread_ptr = HeVAL(thread_entry);
205         SvREFCNT_dec(thread_tid_ptr);   
206         SHAREDSvRELEASE(threads);
207         SHAREDSvUNLOCK(threads);
208
209         obj_ref = newSViv(0);
210         obj = newSVrv(obj_ref, class);
211         sv_setsv(obj, thread_ptr);
212         SvREADONLY_on(obj);
213         return obj_ref;
214 }
215
216 /*
217  * joins the thread this code needs to take the returnvalue from the
218  * call_sv and send it back */
219
220 void Perl_thread_join(SV* obj) {
221         ithread* thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
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
231 /* detaches a thread
232  * needs to better clean up memory */
233
234 void Perl_thread_detach(SV* obj) {
235         ithread* thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
236         MUTEX_LOCK(&thread->mutex);
237         thread->detached = 1;
238         PERL_THREAD_DETACH(thread->thr);
239         MUTEX_UNLOCK(&thread->mutex);
240 }
241
242 void Perl_thread_DESTROY (SV* obj) {
243         ithread* thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
244         
245         MUTEX_LOCK(&thread->mutex);
246         thread->count--;
247         MUTEX_UNLOCK(&thread->mutex);
248         Perl_thread_destruct(thread);
249 }
250
251 void Perl_thread_destruct (ithread* thread) {
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
263 MODULE = threads                PACKAGE = threads               
264 BOOT:
265         Perl_sharedsv_init(aTHX);
266         PERL_THREAD_ALLOC_SPECIFIC(self_key);
267         PL_perl_destruct_level = 2;
268         threads = Perl_sharedsv_new(aTHX);
269         SHAREDSvEDIT(threads);
270         SHAREDSvGET(threads) = (SV *)newHV();
271         SHAREDSvRELEASE(threads);
272         {
273             
274         
275             SV* temp = get_sv("threads::sharedsv_space", TRUE | GV_ADDMULTI);
276             SV* temp2 = newSViv(PTR2IV(PL_sharedsv_space));
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
290                 SHAREDSvEDIT(threads);
291                 PERL_THREAD_ALLOC_SPECIFIC(self_key);
292                 PERL_THREAD_SETSPECIFIC(self_key,0);
293                 thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, 0);
294                 thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
295                 hv_store_ent((HV*) SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
296                 SvREFCNT_dec(thread_tid_ptr);
297                 SHAREDSvRELEASE(threads);
298         }
299         MUTEX_INIT(&create_mutex);
300
301 PROTOTYPES: DISABLE
302
303 SV *
304 create (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                         }
315                         RETVAL = Perl_thread_create(class, function_to_call, newRV_noinc((SV*) params));
316                         OUTPUT:
317                         RETVAL
318
319 SV *
320 new (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
337 SV *
338 self (class)
339                 char* class
340         CODE:
341                 RETVAL = Perl_thread_self(class);
342         OUTPUT:
343                 RETVAL
344
345 int
346 tid (obj)       
347                 SV *    obj;
348         CODE:
349                 RETVAL = Perl_thread_tid(obj);
350         OUTPUT:
351         RETVAL
352
353 void
354 join (obj)
355         SV *    obj
356         PREINIT:
357         I32* temp;
358         PPCODE:
359         temp = PL_markstack_ptr++;
360         Perl_thread_join(obj);
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
369 void
370 detach (obj)
371         SV *    obj
372         PREINIT:
373         I32* temp;
374         PPCODE:
375         temp = PL_markstack_ptr++;
376         Perl_thread_detach(obj);
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
385 void
386 DESTROY (obj)
387         SV *    obj
388         PREINIT:
389         I32* temp;
390         PPCODE:
391         temp = PL_markstack_ptr++;
392         Perl_thread_DESTROY(obj);
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