From: Gurusamy Sarathy Date: Mon, 15 Nov 1999 18:47:34 +0000 (+0000) Subject: add a synchronous stub fork() for USE_ITHREADS to prove that a simple X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8d5630125a4c2a8f0b9bf3e77e79c546fb5c5a6d;p=p5sagit%2Fp5-mst-13.2.git add a synchronous stub fork() for USE_ITHREADS to prove that a simple C works on Windows (incidentally running a cloned^2 interpreter :) p4raw-id: //depot/perl@4589 --- diff --git a/embed.h b/embed.h index eea4c76..55a8c88 100644 --- a/embed.h +++ b/embed.h @@ -764,6 +764,9 @@ #define my_attrs Perl_my_attrs #define boot_core_xsutils Perl_boot_core_xsutils #if defined(USE_ITHREADS) +#define cx_dup Perl_cx_dup +#define si_dup Perl_si_dup +#define ss_dup Perl_ss_dup #define he_dup Perl_he_dup #define re_dup Perl_re_dup #define fp_dup Perl_fp_dup @@ -2133,6 +2136,9 @@ #define my_attrs(a,b) Perl_my_attrs(aTHX_ a,b) #define boot_core_xsutils() Perl_boot_core_xsutils(aTHX) #if defined(USE_ITHREADS) +#define cx_dup(a,b,c) Perl_cx_dup(aTHX_ a,b,c) +#define si_dup(a) Perl_si_dup(aTHX_ a) +#define ss_dup(a,b,c) Perl_ss_dup(aTHX_ a,b,c) #define he_dup(a,b) Perl_he_dup(aTHX_ a,b) #define re_dup(a) Perl_re_dup(aTHX_ a) #define fp_dup(a,b) Perl_fp_dup(aTHX_ a,b) @@ -4204,6 +4210,12 @@ #define Perl_boot_core_xsutils CPerlObj::Perl_boot_core_xsutils #define boot_core_xsutils Perl_boot_core_xsutils #if defined(USE_ITHREADS) +#define Perl_cx_dup CPerlObj::Perl_cx_dup +#define cx_dup Perl_cx_dup +#define Perl_si_dup CPerlObj::Perl_si_dup +#define si_dup Perl_si_dup +#define Perl_ss_dup CPerlObj::Perl_ss_dup +#define ss_dup Perl_ss_dup #define Perl_he_dup CPerlObj::Perl_he_dup #define he_dup Perl_he_dup #define Perl_re_dup CPerlObj::Perl_re_dup diff --git a/embed.pl b/embed.pl index d83e57f..fff791e 100755 --- a/embed.pl +++ b/embed.pl @@ -1773,6 +1773,9 @@ p |void |newMYSUB |I32 floor|OP *o|OP *proto|OP *attrs|OP *block p |OP * |my_attrs |OP *o|OP *attrs p |void |boot_core_xsutils #if defined(USE_ITHREADS) +p |PERL_CONTEXT*|cx_dup |PERL_CONTEXT* cx|I32 ix|I32 max +p |PERL_SI*|si_dup |PERL_SI* si +p |ANY* |ss_dup |ANY* ss|I32 ix|I32 max p |HE* |he_dup |HE* e|bool shared p |REGEXP*|re_dup |REGEXP* r p |PerlIO*|fp_dup |PerlIO* fp|char type diff --git a/global.sym b/global.sym index d151422..e219030 100644 --- a/global.sym +++ b/global.sym @@ -675,6 +675,9 @@ Perl_newATTRSUB Perl_newMYSUB Perl_my_attrs Perl_boot_core_xsutils +Perl_cx_dup +Perl_si_dup +Perl_ss_dup Perl_he_dup Perl_re_dup Perl_fp_dup diff --git a/makedef.pl b/makedef.pl index 428bfc3..40c9be3 100644 --- a/makedef.pl +++ b/makedef.pl @@ -369,6 +369,9 @@ unless ($define{'USE_ITHREADS'}) skip_symbols [qw( PL_ptr_table Perl_dirp_dup +Perl_cx_dup +Perl_si_dup +Perl_ss_dup Perl_fp_dup Perl_gp_dup Perl_he_dup diff --git a/objXSUB.h b/objXSUB.h index 8077c9d..e8b1ffb 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -3534,6 +3534,18 @@ #undef boot_core_xsutils #define boot_core_xsutils Perl_boot_core_xsutils #if defined(USE_ITHREADS) +#undef Perl_cx_dup +#define Perl_cx_dup pPerl->Perl_cx_dup +#undef cx_dup +#define cx_dup Perl_cx_dup +#undef Perl_si_dup +#define Perl_si_dup pPerl->Perl_si_dup +#undef si_dup +#define si_dup Perl_si_dup +#undef Perl_ss_dup +#define Perl_ss_dup pPerl->Perl_ss_dup +#undef ss_dup +#define ss_dup Perl_ss_dup #undef Perl_he_dup #define Perl_he_dup pPerl->Perl_he_dup #undef he_dup diff --git a/perlapi.c b/perlapi.c index 2a7899c..02795ad 100644 --- a/perlapi.c +++ b/perlapi.c @@ -4857,6 +4857,27 @@ Perl_boot_core_xsutils(pTHXo) } #if defined(USE_ITHREADS) +#undef Perl_cx_dup +PERL_CONTEXT* +Perl_cx_dup(pTHXo_ PERL_CONTEXT* cx, I32 ix, I32 max) +{ + return ((CPerlObj*)pPerl)->Perl_cx_dup(cx, ix, max); +} + +#undef Perl_si_dup +PERL_SI* +Perl_si_dup(pTHXo_ PERL_SI* si) +{ + return ((CPerlObj*)pPerl)->Perl_si_dup(si); +} + +#undef Perl_ss_dup +ANY* +Perl_ss_dup(pTHXo_ ANY* ss, I32 ix, I32 max) +{ + return ((CPerlObj*)pPerl)->Perl_ss_dup(ss, ix, max); +} + #undef Perl_he_dup HE* Perl_he_dup(pTHXo_ HE* e, bool shared) diff --git a/pp_sys.c b/pp_sys.c index b2495a0..ebc5e27 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -3582,7 +3582,22 @@ PP(pp_fork) PUSHi(childpid); RETURN; #else +# ifdef USE_ITHREADS + /* XXXXXX testing */ + djSP; dTARGET; + /* XXX this just an approximation of what will eventually be run + * in a different thread */ + PerlInterpreter *new_perl = perl_clone(my_perl, 0); + Perl_pp_enter(new_perl); + new_perl->Top = new_perl->Top->op_next; /* continue from next op */ + CALLRUNOPS(new_perl); + + /* parent returns with negative pseudo-pid */ + PUSHi(-1); + RETURN; +# else DIE(aTHX_ PL_no_func, "Unsupported function fork"); +# endif #endif } diff --git a/proto.h b/proto.h index a4efab9..1204c81 100644 --- a/proto.h +++ b/proto.h @@ -739,6 +739,9 @@ PERL_CALLCONV void Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, O PERL_CALLCONV OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs); PERL_CALLCONV void Perl_boot_core_xsutils(pTHX); #if defined(USE_ITHREADS) +PERL_CALLCONV PERL_CONTEXT* Perl_cx_dup(pTHX_ PERL_CONTEXT* cx, I32 ix, I32 max); +PERL_CALLCONV PERL_SI* Perl_si_dup(pTHX_ PERL_SI* si); +PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ ANY* ss, I32 ix, I32 max); PERL_CALLCONV HE* Perl_he_dup(pTHX_ HE* e, bool shared); PERL_CALLCONV REGEXP* Perl_re_dup(pTHX_ REGEXP* r); PERL_CALLCONV PerlIO* Perl_fp_dup(pTHX_ PerlIO* fp, char type); diff --git a/sv.c b/sv.c index 41c52d8..746f929 100644 --- a/sv.c +++ b/sv.c @@ -6164,15 +6164,16 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cx, I32 ix, I32 max) /* create anew and remember what it is */ Newz(56, ncx, max + 1, PERL_CONTEXT); - ptr_table_store(PL_ptr_table, si, nsi); + ptr_table_store(PL_ptr_table, cx, ncx); + /* XXX todo */ /* ... */ return ncx; } PERL_SI * -Perl_stackinfo_dup(pTHX_ PERL_SI *si) +Perl_si_dup(pTHX_ PERL_SI *si) { PERL_SI *nsi; @@ -6193,17 +6194,18 @@ Perl_stackinfo_dup(pTHX_ PERL_SI *si) nsi->si_cxmax = si->si_cxmax; nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax); nsi->si_type = si->si_type; - nsi->si_prev = stackinfo_dup(si->si_prev); - nsi->si_next = stackinfo_dup(si->si_next); + nsi->si_prev = si_dup(si->si_prev); + nsi->si_next = si_dup(si->si_next); nsi->si_markoff = si->si_markoff; return nsi; } ANY * -Perl_savestack_dup(pTHX_ ANY *ss, I32 ix, I32 max) +Perl_ss_dup(pTHX_ ANY *ss, I32 ix, I32 max) { - /* ... */ + /* XXX todo */ + return NULL; } PerlInterpreter * @@ -6640,10 +6642,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ - PL_markstack_max = proto_perl->Tmarkstack_max; - Newz(54, PL_markstack, PL_markstack_max, I32); - PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack - - proto_perl->Tmarkstack_ptr); + i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack; + Newz(54, PL_markstack, i, I32); + PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max + - proto_perl->Tmarkstack); + PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr + - proto_perl->Tmarkstack); Copy(proto_perl->Tmarkstack, PL_markstack, PL_markstack_ptr - PL_markstack + 1, I32); @@ -6659,9 +6663,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_savestack_ix = proto_perl->Tsavestack_ix; PL_savestack_max = proto_perl->Tsavestack_max; /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/ - PL_savestack = savestack_dup(proto_perl->Tsavestack, - PL_savestack_ix, - PL_savestack_max); + PL_savestack = ss_dup(proto_perl->Tsavestack, + PL_savestack_ix, + PL_savestack_max); /* next push_return() sets PL_retstack[PL_retstack_ix] * NOTE: unlike the others! */ @@ -6670,8 +6674,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Newz(54, PL_retstack, PL_retstack_max, OP*); Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32); - /* NOTE: stackinfo_dup() looks at PL_markstack */ - PL_curstackinfo = stackinfo_dup(proto_perl->Tcurstackinfo); + /* NOTE: si_dup() looks at PL_markstack */ + PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo); /* PL_curstack = PL_curstackinfo->si_stack; */ PL_curstack = av_dup(proto_perl->Tcurstack);