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 #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         thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread->thr));
27         thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
28         hv_store_ent((HV*)SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
29         SvREFCNT_dec(thread_tid_ptr);
30         SHAREDSvRELEASE(threads);
31         SHAREDSvUNLOCK(threads);
32         PL_perl_destruct_level = 2;
33
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;
51                 call_sv(thread->init_function, G_DISCARD);
52                 FREETMPS;
53                 LEAVE;
54
55
56         }
57
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);
63                 Perl_thread_destruct(thread);
64         } else {
65                 MUTEX_UNLOCK(&thread->mutex);
66         }
67 #ifdef WIN32
68         return (DWORD)0;
69 #else
70         return 0;
71 #endif
72
73 }
74
75 /*
76  * iThread->create();
77  */
78
79 SV* Perl_thread_create(char* class, SV* init_function, SV* params) {
80         ithread* thread = malloc(sizeof(ithread));
81         SV*      obj_ref;
82         SV*      obj;
83         SV*             temp_store;
84         PerlInterpreter *current_perl;
85
86         MUTEX_LOCK(&create_mutex);  
87         obj_ref = newSViv(0);
88         obj = newSVrv(obj_ref, class);
89         sv_setiv(obj, (IV)thread);
90         SvREADONLY_on(obj);
91
92         current_perl = PERL_GET_CONTEXT;        
93
94         /*
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          */
99
100         temp_store = Perl_get_sv(current_perl, "threads::paramtempstore",
101                                  TRUE | GV_ADDMULTI);
102         Perl_sv_setsv(current_perl, temp_store,params);
103         params = NULL;
104         temp_store = NULL;
105
106         temp_store = Perl_get_sv(current_perl, "threads::calltempstore",
107                                  TRUE | GV_ADDMULTI);
108         Perl_sv_setsv(current_perl,temp_store, init_function);
109         init_function = NULL;
110         temp_store = NULL;
111
112 #ifdef WIN32
113         thread->interp = perl_clone(current_perl, 4);
114 #else
115         thread->interp = perl_clone(current_perl, 0);
116 #endif
117
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));
122
123         /*
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 */
127
128         temp_store = Perl_get_sv(thread->interp, "threads::paramtempstore",FALSE);
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
142         /* let's init the thread */
143
144         MUTEX_INIT(&thread->mutex);
145         thread->tid = tid_counter++;
146         thread->detached = 0;
147         thread->count = 1;
148
149 #ifdef WIN32
150
151         thread->handle = CreateThread(NULL, 0, Perl_thread_run,
152                         (LPVOID)thread, 0, &thread->thr);
153
154 #else
155         pthread_create( &thread->thr, (pthread_attr_t*)NULL, Perl_thread_run, thread);
156 #endif
157         MUTEX_UNLOCK(&create_mutex);    
158
159         return obj_ref;
160 }
161
162 /*
163  * returns the id of the thread
164  */
165 I32 Perl_thread_tid (SV* obj) {
166         ithread* thread;
167         if(!SvROK(obj)) {
168                 obj = Perl_thread_self(SvPV_nolen(obj));
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
177 SV* Perl_thread_self (char* class) {
178         dTHX;
179         SV*      obj_ref;
180         SV*      obj;
181         SV*     thread_tid_ptr;
182         SV*     thread_ptr;
183         HE*     thread_entry;
184         
185         SHAREDSvLOCK(threads);
186         SHAREDSvEDIT(threads);
187 #ifdef WIN32
188         thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space,
189                                       (UV) GetCurrentThreadId());
190 #else
191         thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space,
192                                       PTR2UV(pthread_self()));
193 #endif
194         thread_entry = Perl_hv_fetch_ent(PL_sharedsv_space,
195                                          (HV*) SHAREDSvGET(threads),
196                                          thread_tid_ptr, 0,0);
197         thread_ptr = HeVAL(thread_entry);
198         SvREFCNT_dec(thread_tid_ptr);   
199         SHAREDSvRELEASE(threads);
200         SHAREDSvUNLOCK(threads);
201
202         obj_ref = newSViv(0);
203         obj = newSVrv(obj_ref, class);
204         sv_setsv(obj, thread_ptr);
205         SvREADONLY_on(obj);
206         return obj_ref;
207 }
208
209 /*
210  * joins the thread this code needs to take the returnvalue from the
211  * call_sv and send it back */
212
213 void Perl_thread_join(SV* obj) {
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
224 /* detaches a thread
225  * needs to better clean up memory */
226
227 void Perl_thread_detach(SV* obj) {
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
237 void Perl_thread_DESTROY (SV* obj) {
238         ithread* thread = (ithread*)SvIV(SvRV(obj));
239         
240         MUTEX_LOCK(&thread->mutex);
241         thread->count--;
242         MUTEX_UNLOCK(&thread->mutex);
243         Perl_thread_destruct(thread);
244 }
245
246 void Perl_thread_destruct (ithread* thread) {
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
258 MODULE = threads                PACKAGE = threads               
259 BOOT:
260         Perl_sharedsv_init(aTHX);
261         PL_perl_destruct_level = 2;
262         threads = Perl_sharedsv_new(aTHX);
263         SHAREDSvEDIT(threads);
264         SHAREDSvGET(threads) = (SV *)newHV();
265         SHAREDSvRELEASE(threads);
266         {
267             
268         
269             SV* temp = get_sv("threads::sharedsv_space", TRUE | GV_ADDMULTI);
270             SV* temp2 = newSViv((IV)PL_sharedsv_space );
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
284                 thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread->thr));
285                 thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
286                 SHAREDSvEDIT(threads);
287                 hv_store_ent((HV*) SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
288                 SHAREDSvRELEASE(threads);
289                 SvREFCNT_dec(thread_tid_ptr);
290         }
291         MUTEX_INIT(&create_mutex);
292
293 PROTOTYPES: DISABLE
294
295 SV *
296 create (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                         }
307                         RETVAL = Perl_thread_create(class, function_to_call, newRV_noinc((SV*) params));
308                         OUTPUT:
309                         RETVAL
310
311 SV *
312 self (class)
313                 char* class
314         CODE:
315                 RETVAL = Perl_thread_self(class);
316         OUTPUT:
317                 RETVAL
318
319 int
320 tid (obj)       
321                 SV *    obj;
322         CODE:
323                 RETVAL = Perl_thread_tid(obj);
324         OUTPUT:
325         RETVAL
326
327 void
328 join (obj)
329         SV *    obj
330         PREINIT:
331         I32* temp;
332         PPCODE:
333         temp = PL_markstack_ptr++;
334         Perl_thread_join(obj);
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
343 void
344 detach (obj)
345         SV *    obj
346         PREINIT:
347         I32* temp;
348         PPCODE:
349         temp = PL_markstack_ptr++;
350         Perl_thread_detach(obj);
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
359 void
360 DESTROY (obj)
361         SV *    obj
362         PREINIT:
363         I32* temp;
364         PPCODE:
365         temp = PL_markstack_ptr++;
366         Perl_thread_DESTROY(obj);
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