This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
amigaos4: add amigaos the glue code
[perl5.git] / amigaos4 / amigaio.c
1 /* amigaio.c mixes amigaos and perl APIs,
2  * as opposed to amigaos.c which is pure amigaos */
3
4 #include "EXTERN.h"
5 #include "perl.h"
6
7 #include "amigaos4/amigaio.h"
8 #include "amigaos.h"
9
10 #ifdef WORD
11 #  undef WORD
12 #  define WORD int16
13 #endif
14
15 #include <exec/semaphores.h>
16 #include <exec/exectags.h>
17 #include <proto/exec.h>
18 #include <proto/dos.h>
19 #include <dos/dos.h>
20
21 void amigaos_stdio_get(pTHX_ StdioStore *store)
22 {
23         store->astdin =
24             amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stdingv))));
25         store->astderr =
26             amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stderrgv))));
27         store->astdout = amigaos_get_file(
28             PerlIO_fileno(IoIFP(GvIO(gv_fetchpv("STDOUT", TRUE, SVt_PVIO)))));
29 }
30
31 void amigaos_stdio_save(pTHX_ StdioStore *store)
32 {
33         amigaos_stdio_get(aTHX_ store);
34         store->oldstdin = IDOS->SelectInput(store->astdin);
35         store->oldstderr = IDOS->SelectErrorOutput(store->astderr);
36         store->oldstdout = IDOS->SelectOutput(store->astdout);
37 }
38
39 void amigaos_stdio_restore(pTHX_ const StdioStore *store)
40 {
41         IDOS->SelectInput(store->oldstdin);
42         IDOS->SelectErrorOutput(store->oldstderr);
43         IDOS->SelectOutput(store->oldstdout);
44 }
45
46 void amigaos_post_exec(int fd, int do_report)
47 {
48         /* We *must* write something to our pipe or else
49          * the other end hangs */
50         if (do_report)
51         {
52                 int e = errno;
53                 PerlLIO_write(fd, (void *)&e, sizeof(e));
54                 PerlLIO_close(fd);
55         }
56 }
57
58 PerlIO *Perl_my_popen(pTHX_ const char *cmd, const char *mode)
59 {
60         PERL_FLUSHALL_FOR_CHILD;
61         /* Call system's popen() to get a FILE *, then import it.
62          * used 0 for 2nd parameter to PerlIO_importFILE;
63          * apparently not used
64         */
65         //    FILE *f=amigaos_popen(cmd,mode);
66         //    fprintf(stderr,"popen returned %d\n",f);
67         return PerlIO_importFILE(amigaos_popen(cmd, mode), 0);
68         //   return PerlIO_importFILE(f, 0);
69 }
70
71 #ifdef USE_ITHREADS
72
73 /* An arbitrary number to start with, should work out what the real max should
74  * be */
75
76 #ifndef MAX_THREADS
77 #  define MAX_THREADS 64
78 #endif
79
80 #define REAPED 0
81 #define ACTIVE 1
82 #define EXITED -1
83
84 struct thread_info
85 {
86         pthread_t ti_pid;
87         int ti_children;
88         pthread_t ti_parent;
89         struct MsgPort *ti_port;
90 };
91
92 static struct thread_info pseudo_children[MAX_THREADS];
93 static int num_pseudo_children = 0;
94 static struct SignalSemaphore fork_array_sema;
95
96 void amigaos4_init_fork_array()
97 {
98         IExec->InitSemaphore(&fork_array_sema);
99         pseudo_children[0].ti_pid = (pthread_t)IExec->FindTask(0);
100         pseudo_children[0].ti_parent = -1;
101         pseudo_children[0].ti_port =
102             (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE);
103 }
104
105 void amigaos4_dispose_fork_array()
106 {
107         while (pseudo_children[0].ti_children > 0)
108         {
109                 void *msg;
110                 IExec->WaitPort(pseudo_children[0].ti_port);
111                 msg = IExec->GetMsg(pseudo_children[0].ti_port);
112                 if (msg)
113                         IExec->FreeSysObject(ASOT_MESSAGE, msg);
114                 pseudo_children[0].ti_children--;
115         }
116         IExec->FreeSysObject(ASOT_PORT, pseudo_children[0].ti_port);
117 }
118
119 struct thread_exit_message
120 {
121         struct Message tem_Message;
122         pthread_t tem_pid;
123         int tem_status;
124 };
125
126 int getnextchild()
127 {
128         int i;
129         for (i = 0; i < MAX_THREADS; i++)
130         {
131                 if (pseudo_children[i].ti_pid == 0)
132                         return i;
133         }
134         return -1;
135 }
136
137 int findparent(pthread_t pid)
138 {
139         int i;
140         for (i = 0; i < MAX_THREADS; i++)
141         {
142                 if (pseudo_children[i].ti_pid == pid)
143                         return i;
144         }
145         return -1;
146 }
147
148 struct child_arg
149 {
150         struct Task *ca_parent_task;
151         pthread_t ca_parent;
152         PerlInterpreter *ca_interp;
153 };
154
155 static THREAD_RET_TYPE amigaos4_start_child(void *arg)
156 {
157
158         PerlInterpreter *my_perl =
159             (PerlInterpreter *)((struct child_arg *)arg)->ca_interp;
160         ;
161
162         GV *tmpgv;
163         int status;
164         int parent;
165         int nextchild;
166         pthread_t pseudo_id = pthread_self();
167
168 #ifdef PERL_SYNC_FORK
169         static long sync_fork_id = 0;
170         long id = ++sync_fork_id;
171 #endif
172
173         /* before we do anything set up our process semaphore and add
174            a new entry to the pseudochildren */
175
176         /* get next available slot */
177         /* should not fail here! */
178
179         IExec->ObtainSemaphore(&fork_array_sema);
180
181         nextchild = getnextchild();
182
183         pseudo_children[nextchild].ti_pid = pseudo_id;
184         pseudo_children[nextchild].ti_parent =
185             ((struct child_arg *)arg)->ca_parent;
186         pseudo_children[nextchild].ti_port =
187             (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE);
188
189         num_pseudo_children++;
190         IExec->ReleaseSemaphore(&fork_array_sema);
191
192         /* We're set up let the parent continue */
193
194         IExec->Signal(((struct child_arg *)arg)->ca_parent_task,
195                       SIGBREAKF_CTRL_F);
196
197         PERL_SET_THX(my_perl);
198         if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
199         {
200                 SV *sv = GvSV(tmpgv);
201                 SvREADONLY_off(sv);
202                 sv_setiv(sv, (IV)pseudo_id);
203                 SvREADONLY_on(sv);
204         }
205         hv_clear(PL_pidstatus);
206
207         /* push a zero on the stack (we are the child) */
208         {
209                 dSP;
210                 dTARGET;
211                 PUSHi(0);
212                 PUTBACK;
213         }
214
215         /* continue from next op */
216         PL_op = PL_op->op_next;
217
218         {
219                 dJMPENV;
220                 volatile int oldscope = PL_scopestack_ix;
221
222         restart:
223                 JMPENV_PUSH(status);
224                 switch (status)
225                 {
226                 case 0:
227                         CALLRUNOPS(aTHX);
228                         status = 0;
229                         break;
230                 case 2:
231                         while (PL_scopestack_ix > oldscope)
232                         {
233                                 LEAVE;
234                         }
235                         FREETMPS;
236                         PL_curstash = PL_defstash;
237                         if (PL_endav && !PL_minus_c)
238                                 call_list(oldscope, PL_endav);
239                         status = STATUS_EXIT;
240                         break;
241                 case 3:
242                         if (PL_restartop)
243                         {
244                                 POPSTACK_TO(PL_mainstack);
245                                 PL_op = PL_restartop;
246                                 PL_restartop = (OP *)NULL;
247                                 ;
248                                 goto restart;
249                         }
250                         PerlIO_printf(Perl_error_log, "panic: restartop\n");
251                         FREETMPS;
252                         status = 1;
253                         break;
254                 }
255                 JMPENV_POP;
256
257                 /* XXX hack to avoid perl_destruct() freeing optree */
258                 PL_main_root = (OP *)NULL;
259         }
260
261         {
262                 do_close(PL_stdingv, FALSE);
263                 do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO),
264                          FALSE); /* PL_stdoutgv - ISAGN */
265                 do_close(PL_stderrgv, FALSE);
266         }
267
268         /* destroy everything (waits for any pseudo-forked children) */
269
270         /* wait for any remaining children */
271
272         while (pseudo_children[nextchild].ti_children > 0)
273         {
274                 if (IExec->WaitPort(pseudo_children[nextchild].ti_port))
275                 {
276                         void *msg =
277                             IExec->GetMsg(pseudo_children[nextchild].ti_port);
278                         IExec->FreeSysObject(ASOT_MESSAGE, msg);
279                         pseudo_children[nextchild].ti_children--;
280                 }
281         }
282         if (PL_scopestack_ix <= 1)
283         {
284                 perl_destruct(my_perl);
285         }
286         perl_free(my_perl);
287
288         IExec->ObtainSemaphore(&fork_array_sema);
289         parent = findparent(pseudo_children[nextchild].ti_parent);
290         pseudo_children[nextchild].ti_pid = 0;
291         pseudo_children[nextchild].ti_parent = 0;
292         IExec->FreeSysObject(ASOT_PORT, pseudo_children[nextchild].ti_port);
293         pseudo_children[nextchild].ti_port = NULL;
294
295         IExec->ReleaseSemaphore(&fork_array_sema);
296
297         {
298                 if (parent >= 0)
299                 {
300                         struct thread_exit_message *tem =
301                             (struct thread_exit_message *)
302                                 IExec->AllocSysObjectTags(
303                                     ASOT_MESSAGE, ASOMSG_Size,
304                                     sizeof(struct thread_exit_message),
305                                     ASOMSG_Length,
306                                     sizeof(struct thread_exit_message));
307                         if (tem)
308                         {
309                                 tem->tem_pid = pseudo_id;
310                                 tem->tem_status = status;
311                                 IExec->PutMsg(pseudo_children[parent].ti_port,
312                                               (struct Message *)tem);
313                         }
314                 }
315         }
316 #ifdef PERL_SYNC_FORK
317         return id;
318 #else
319         return (void *)status;
320 #endif
321 }
322
323 #endif /* USE_ITHREADS */
324
325 Pid_t amigaos_fork()
326 {
327         dTHX;
328         pthread_t id;
329         int handle;
330         struct child_arg arg;
331         if (num_pseudo_children >= MAX_THREADS)
332         {
333                 errno = EAGAIN;
334                 return -1;
335         }
336         arg.ca_interp = perl_clone((PerlInterpreter *)aTHX, CLONEf_COPY_STACKS);
337         arg.ca_parent_task = IExec->FindTask(NULL);
338         arg.ca_parent =
339             pthread_self() ? pthread_self() : (pthread_t)IExec->FindTask(0);
340
341         handle = pthread_create(&id, NULL, amigaos4_start_child, (void *)&arg);
342         pseudo_children[findparent(arg.ca_parent)].ti_children++;
343
344         IExec->Wait(SIGBREAKF_CTRL_F);
345
346         PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */
347         if (handle)
348         {
349                 errno = EAGAIN;
350                 return -1;
351         }
352         return id;
353 }
354
355 Pid_t amigaos_waitpid(pTHX_ int optype, Pid_t pid, void *argflags)
356 {
357         int result;
358         if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
359         {
360                 result = pthread_join(pid, argflags);
361         }
362         else
363         {
364                 while ((result = pthread_join(pid, argflags)) == -1 &&
365                        errno == EINTR)
366                 {
367                         //          PERL_ASYNC_CHECK();
368                 }
369         }
370         return result;
371 }
372
373 void amigaos_fork_set_userdata(
374     pTHX_ struct UserData *userdata, I32 did_pipes, int pp, SV **sp, SV **mark)
375 {
376         userdata->parent = IExec->FindTask(0);
377         userdata->did_pipes = did_pipes;
378         userdata->pp = pp;
379         userdata->sp = sp;
380         userdata->mark = mark;
381         userdata->my_perl = aTHX;
382 }
383
384 void *amigaos_system_child(void *userdata)
385 {
386         struct Task *parent;
387         I32 did_pipes;
388         int pp;
389         I32 value;
390         STRLEN n_a;
391         /* these next are declared by macros else where but I may be
392          * passing modified values here so declare them explictly but
393          * still referred to by macro below */
394
395         register SV **sp;
396         register SV **mark;
397         register PerlInterpreter *my_perl;
398
399         StdioStore store;
400
401         struct UserData *ud = (struct UserData *)userdata;
402
403         did_pipes = ud->did_pipes;
404         parent = ud->parent;
405         pp = ud->pp;
406         SP = ud->sp;
407         MARK = ud->mark;
408         my_perl = ud->my_perl;
409         PERL_SET_THX(my_perl);
410
411         amigaos_stdio_save(aTHX_ & store);
412
413         if (did_pipes)
414         {
415                 //    PerlLIO_close(pp[0]);
416         }
417         if (PL_op->op_flags & OPf_STACKED)
418         {
419                 SV *really = *++MARK;
420                 value = (I32)do_aexec5(really, MARK, SP, pp, did_pipes);
421         }
422         else if (SP - MARK != 1)
423         {
424                 value = (I32)do_aexec5(NULL, MARK, SP, pp, did_pipes);
425         }
426         else
427         {
428                 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp,
429                                       did_pipes);
430         }
431
432         //    Forbid();
433         //    Signal(parent, SIGBREAKF_CTRL_F);
434
435         amigaos_stdio_restore(aTHX_ & store);
436
437         return value;
438 }