add a synchronous stub fork() for USE_ITHREADS to prove that a simple

C<if (fork()) { print "parent" } else { print "child" }> 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 (file)
--- 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 (executable)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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);