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