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