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

9 files changed, 91 insertions, 15 deletions

diff --git a/embed.h b/embed.h
index eea4c764c2..55a8c88ca2 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 d83e57f038..fff791e923 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 d15142263d..e21903093c 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 428bfc38b4..40c9be3a26 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 8077c9dc26..e8b1ffb838 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 2a7899cb37..02795ad30d 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 b2495a06dc..ebc5e2776c 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 a4efab930f..1204c812af 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 41c52d835c..746f92956d 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);