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