re-implement MY_CXT API more efficiently, and add explicit

interpeter arg variant

p4raw-id: //depot/perl@26523

12 files changed, 136 insertions, 22 deletions

diff --git a/embed.fnc b/embed.fnc
index 46d12a209e..5aed31e9cb 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1609,6 +1609,11 @@ Apnod	|int	|my_sprintf	|NN char *buffer|NN const char *pat|...
 
 px	|void	|my_clearenv
 
+#ifdef PERL_IMPLICIT_CONTEXT
+po	|void*	|my_cxt_init	|NN int *index|size_t size
+#endif
+
+
 END_EXTERN_C
 /*
  * ex: set ts=8 sts=4 sw=4 noet:
diff --git a/embed.h b/embed.h
index c0e3b52b5e..6e831a0ed9 100644
--- a/embed.h
+++ b/embed.h
@@ -1691,6 +1691,8 @@
 #ifdef PERL_CORE
 #define my_clearenv		Perl_my_clearenv
 #endif
+#ifdef PERL_IMPLICIT_CONTEXT
+#endif
 #define ck_anoncode		Perl_ck_anoncode
 #define ck_bitop		Perl_ck_bitop
 #define ck_concat		Perl_ck_concat
@@ -3727,6 +3729,10 @@
 #ifdef PERL_CORE
 #define my_clearenv()		Perl_my_clearenv(aTHX)
 #endif
+#ifdef PERL_IMPLICIT_CONTEXT
+#ifdef PERL_CORE
+#endif
+#endif
 #define ck_anoncode(a)		Perl_ck_anoncode(aTHX_ a)
 #define ck_bitop(a)		Perl_ck_bitop(aTHX_ a)
 #define ck_concat(a)		Perl_ck_concat(aTHX_ a)
diff --git a/embedvar.h b/embedvar.h
index ca344b81c9..3f4a8804ee 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -320,6 +320,8 @@
 #define PL_multi_open		(vTHX->Imulti_open)
 #define PL_multi_start		(vTHX->Imulti_start)
 #define PL_multiline		(vTHX->Imultiline)
+#define PL_my_cxt_list		(vTHX->Imy_cxt_list)
+#define PL_my_cxt_size		(vTHX->Imy_cxt_size)
 #define PL_nexttoke		(vTHX->Inexttoke)
 #define PL_nexttype		(vTHX->Inexttype)
 #define PL_nextval		(vTHX->Inextval)
@@ -600,6 +602,8 @@
 #define PL_Imulti_open		PL_multi_open
 #define PL_Imulti_start		PL_multi_start
 #define PL_Imultiline		PL_multiline
+#define PL_Imy_cxt_list		PL_my_cxt_list
+#define PL_Imy_cxt_size		PL_my_cxt_size
 #define PL_Inexttoke		PL_nexttoke
 #define PL_Inexttype		PL_nexttype
 #define PL_Inextval		PL_nextval
@@ -862,6 +866,10 @@
 #define PL_Gmalloc_mutex	(my_vars->Gmalloc_mutex)
 #define PL_mmap_page_size	(my_vars->Gmmap_page_size)
 #define PL_Gmmap_page_size	(my_vars->Gmmap_page_size)
+#define PL_my_ctx_mutex		(my_vars->Gmy_ctx_mutex)
+#define PL_Gmy_ctx_mutex	(my_vars->Gmy_ctx_mutex)
+#define PL_my_cxt_index		(my_vars->Gmy_cxt_index)
+#define PL_Gmy_cxt_index	(my_vars->Gmy_cxt_index)
 #define PL_op_mutex		(my_vars->Gop_mutex)
 #define PL_Gop_mutex		(my_vars->Gop_mutex)
 #define PL_op_seq		(my_vars->Gop_seq)
@@ -915,6 +923,8 @@
 #define PL_Ghexdigit		PL_hexdigit
 #define PL_Gmalloc_mutex	PL_malloc_mutex
 #define PL_Gmmap_page_size	PL_mmap_page_size
+#define PL_Gmy_ctx_mutex	PL_my_ctx_mutex
+#define PL_Gmy_cxt_index	PL_my_cxt_index
 #define PL_Gop_mutex		PL_op_mutex
 #define PL_Gop_seq		PL_op_seq
 #define PL_Gop_sequence		PL_op_sequence
diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index 22279bc6e7..c2a647800a 100644
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -16,16 +16,31 @@ typedef struct {
 START_MY_CXT
 
 /* indirect functions to test the [pa]MY_CXT macros */
+
 int
 my_cxt_getint_p(pMY_CXT)
 {
     return MY_CXT.i;
 }
+
 void
 my_cxt_setint_p(pMY_CXT_ int i)
 {
     MY_CXT.i = i;
 }
+
+SV*
+my_cxt_getsv_interp()
+{
+#ifdef PERL_IMPLICIT_CONTEXT
+    dTHX;
+    dMY_CXT_INTERP(my_perl);
+#else
+    dMY_CXT;
+#endif
+    return MY_CXT.sv;
+}
+
 void
 my_cxt_setsv_p(SV* sv _pMY_CXT)
 {
@@ -33,7 +48,6 @@ my_cxt_setsv_p(SV* sv _pMY_CXT)
 }
 
 
-
 /* from exception.c */
 int exception(int);
 
@@ -477,9 +491,8 @@ my_cxt_setint(i)
 void
 my_cxt_getsv()
     PPCODE:
-	dMY_CXT;
 	EXTEND(SP, 1);
-	ST(0) = MY_CXT.sv;
+	ST(0) = my_cxt_getsv_interp();
 	XSRETURN(1);
 
 void
diff --git a/intrpvar.h b/intrpvar.h
index 04ea137362..931ac461fb 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -517,6 +517,12 @@ PERLVARI(Isuidscript, int, -1)	/* fd for suid script */
 /* File descriptor to talk to the child which dumps scalars.  */
 PERLVARI(Idumper_fd, int, -1)
 #endif
+
+#ifdef PERL_IMPLICIT_CONTEXT
+PERLVARI(Imy_cxt_size, int, -1)		/* size of PL_my_cxt_list */
+PERLVARI(Imy_cxt_list, void **, NULL) /* per-module array of MY_CXT pointers */
+#endif
+
 /* New variables must be added to the very end, before this comment,
  * for binary compatibility (the offsets of the old members must not change).
  * (Don't forget to add your variable also to perl_clone()!)
diff --git a/perl.h b/perl.h
index f478c22b9f..d4efd902d4 100644
--- a/perl.h
+++ b/perl.h
@@ -5094,6 +5094,7 @@ typedef struct am_table_short AMTS;
  * Code that uses these macros is responsible for the following:
  * 1. #define MY_CXT_KEY to a unique string, e.g.
  *    "DynaLoader::_guts" XS_VERSION
+ *    XXX in the current implementation, this string is ignored.
  * 2. Declare a typedef named my_cxt_t that is a structure that contains
  *    all the data that needs to be interpreter-local.
  * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
@@ -5110,35 +5111,30 @@ typedef struct am_table_short AMTS;
 /* This must appear in all extensions that define a my_cxt_t structure,
  * right after the definition (i.e. at file scope).  The non-threads
  * case below uses it to declare the data as static. */
-#define START_MY_CXT
-
-/* Fetches the SV that keeps the per-interpreter data. */
-#define dMY_CXT_SV \
-	SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY,		\
-				  sizeof(MY_CXT_KEY)-1, TRUE)
+#define START_MY_CXT static int my_cxt_index = -1;
 
 /* This declaration should be used within all functions that use the
  * interpreter-local data. */
 #define dMY_CXT	\
-	dMY_CXT_SV;							\
-	my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*, SvUV(my_cxt_sv))
+	my_cxt_t *my_cxtp = (my_cxt_t *)PL_my_cxt_list[my_cxt_index]
+#define dMY_CXT_INTERP(my_perl)	\
+	my_cxt_t *my_cxtp = (my_cxt_t *)(my_perl)->Imy_cxt_list[my_cxt_index]
 
 /* Creates and zeroes the per-interpreter data.
  * (We allocate my_cxtp in a Perl SV so that it will be released when
  * the interpreter goes away.) */
 #define MY_CXT_INIT \
-	dMY_CXT_SV;							\
-	/* newSV() allocates one more than needed */			\
-	my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
-	Zero(my_cxtp, 1, my_cxt_t);					\
-	sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+	my_cxt_t *my_cxtp = \
+	    (my_cxt_t*)Perl_my_cxt_init(aTHX_ &my_cxt_index, sizeof(my_cxt_t))
+#define MY_CXT_INIT_INTERP(my_perl) \
+	my_cxt_t *my_cxtp = \
+	    (my_cxt_t*)Perl_my_cxt_init(my_perl, &my_cxt_index, sizeof(my_cxt_t))
 
 /* Clones the per-interpreter data. */
 #define MY_CXT_CLONE \
-	dMY_CXT_SV;							\
 	my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
-	Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
-	sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+	Copy(PL_my_cxt_list[my_cxt_index], my_cxtp, 1, my_cxt_t);\
+	PL_my_cxt_list[my_cxt_index] = my_cxtp				\
 
 /* This macro must be used to access members of the my_cxt_t structure.
  * e.g. MYCXT.some_data */
@@ -5153,7 +5149,7 @@ typedef struct am_table_short AMTS;
 #define aMY_CXT_	aMY_CXT,
 #define _aMY_CXT	,aMY_CXT
 
-#else /* USE_ITHREADS */
+#else /* PERL_IMPLICIT_CONTEXT */
 
 #define START_MY_CXT	static my_cxt_t my_cxt;
 #define dMY_CXT_SV	dNOOP
@@ -5169,7 +5165,7 @@ typedef struct am_table_short AMTS;
 #define aMY_CXT_
 #define _aMY_CXT
 
-#endif /* !defined(USE_ITHREADS) */
+#endif /* !defined(PERL_IMPLICIT_CONTEXT) */
 
 #ifdef I_FCNTL
 #  include <fcntl.h>
diff --git a/perlapi.h b/perlapi.h
index fff51f6ba4..8a8aa0020d 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -438,6 +438,10 @@ END_EXTERN_C
 #define PL_multi_start		(*Perl_Imulti_start_ptr(aTHX))
 #undef  PL_multiline
 #define PL_multiline		(*Perl_Imultiline_ptr(aTHX))
+#undef  PL_my_cxt_list
+#define PL_my_cxt_list		(*Perl_Imy_cxt_list_ptr(aTHX))
+#undef  PL_my_cxt_size
+#define PL_my_cxt_size		(*Perl_Imy_cxt_size_ptr(aTHX))
 #undef  PL_nexttoke
 #define PL_nexttoke		(*Perl_Inexttoke_ptr(aTHX))
 #undef  PL_nexttype
@@ -926,6 +930,10 @@ END_EXTERN_C
 #define PL_malloc_mutex		(*Perl_Gmalloc_mutex_ptr(NULL))
 #undef  PL_mmap_page_size
 #define PL_mmap_page_size	(*Perl_Gmmap_page_size_ptr(NULL))
+#undef  PL_my_ctx_mutex
+#define PL_my_ctx_mutex		(*Perl_Gmy_ctx_mutex_ptr(NULL))
+#undef  PL_my_cxt_index
+#define PL_my_cxt_index		(*Perl_Gmy_cxt_index_ptr(NULL))
 #undef  PL_op_mutex
 #define PL_op_mutex		(*Perl_Gop_mutex_ptr(NULL))
 #undef  PL_op_seq
diff --git a/perlvars.h b/perlvars.h
index 9f3a399161..c15b6667dd 100644
--- a/perlvars.h
+++ b/perlvars.h
@@ -124,4 +124,9 @@ PERLVARI(Gop_seq, UV, 0) /* dump.c */
 PERLVAR(Gtimesbase, struct tms)
 #endif
 
+/* allocate a unique index to every module that calls MY_CXT_INIT */
 
+#ifdef PERL_IMPLICIT_CONTEXT
+PERLVAR(Gmy_ctx_mutex, perl_mutex)
+PERLVARI(Gmy_cxt_index, int, 0)
+#endif
diff --git a/pod/perlxs.pod b/pod/perlxs.pod
index b3ba08f56a..e6f1862e56 100644
--- a/pod/perlxs.pod
+++ b/pod/perlxs.pod
@@ -1926,7 +1926,6 @@ Below is an example module that makes use of the macros.
 	CODE:
 	MY_CXT_CLONE;
 
-
 B<REFERENCE>
 
 =over 5
@@ -2013,8 +2012,19 @@ my_cxt_t structure. Calling C<MY_CXT_CLONE> (typically via the package's
 C<CLONE()> function), causes a byte-for-byte copy of the structure to be
 taken, and any future dMY_CXT will cause the copy to be accessed instead.
 
+=item MY_CXT_INIT_INTERP(my_perl)
+
+=item dMY_CXT_INTERP(my_perl)
+
+These are versions of the macros which take an explicit interpreter as an
+argument.
+
 =back
 
+Note that these macros will only work together within the I<same> source
+file; that is, a dMY_CTX in one source file will access a different structure
+than a dMY_CTX in another source file.
+
 =head1 EXAMPLES
 
 File C<RPC.xs>: Interface to some ONC+ RPC bind library functions.
diff --git a/proto.h b/proto.h
index e115a4171a..fbf3c865dd 100644
--- a/proto.h
+++ b/proto.h
@@ -4206,6 +4206,13 @@ PERL_CALLCONV int	Perl_my_sprintf(char *buffer, const char *pat, ...)
 
 PERL_CALLCONV void	Perl_my_clearenv(pTHX);
 
+#ifdef PERL_IMPLICIT_CONTEXT
+PERL_CALLCONV void*	Perl_my_cxt_init(pTHX_ int *index, size_t size)
+			__attribute__nonnull__(pTHX_1);
+
+#endif
+
+
 END_EXTERN_C
 /*
  * ex: set ts=8 sts=4 sw=4 noet:
diff --git a/sv.c b/sv.c
index d797a9fa7c..f11f219414 100644
--- a/sv.c
+++ b/sv.c
@@ -10394,6 +10394,14 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     }
     else
 	PL_exitlist	= (PerlExitListEntry*)NULL;
+
+    PL_my_cxt_size = proto_perl->Imy_cxt_size;
+    if (PL_my_cxt_size) {
+	Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+	Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
+    }
+    else
+	PL_my_cxt_list	= (void**)NULL;
     PL_modglobal	= hv_dup_inc(proto_perl->Imodglobal, param);
     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
diff --git a/util.c b/util.c
index d681d04e12..4976c7517e 100644
--- a/util.c
+++ b/util.c
@@ -5199,6 +5199,46 @@ Perl_my_clearenv(pTHX)
 #endif /* PERL_MICRO */
 }
 
+#ifdef PERL_IMPLICIT_CONTEXT
+
+/* implements the MY_CXT_INIT macro. The first time a module is loaded,
+the global PL_my_cxt_index is incremented, and that value is assigned to
+that module's static my_cxt_index (who's address is passed as an arg).
+Then, for each interpreter this function is called for, it makes sure a
+void* slot is available to hang the static data off, by allocating or
+extending the interpreter's PL_my_cxt_list array */
+
+void *
+Perl_my_cxt_init(pTHX_ int *index, size_t size)
+{
+    void *p;
+    if (*index == -1) {
+	/* this module hasn't been allocated an index yet */
+	MUTEX_LOCK(&PL_my_ctx_mutex);
+	*index = PL_my_cxt_index++;
+	MUTEX_UNLOCK(&PL_my_ctx_mutex);
+    }
+    
+    /* make sure the array is big enough */
+    if (PL_my_cxt_size < *index + 1) {
+	if (PL_my_cxt_list) {
+	    while (PL_my_cxt_size < *index + 1)
+		PL_my_cxt_size *= 2;
+	    Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
+	}
+	else {
+	    PL_my_cxt_size = 16;
+	    Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+	}
+    }
+    /* newSV() allocates one more than needed */
+    p = (void*)SvPVX(newSV(size-1));
+    PL_my_cxt_list[*index] = p;
+    Zero(p, size, char);
+    return p;
+}
+#endif
+
 /*
  * Local variables:
  * c-indentation-style: bsd