diff options
| -rw-r--r-- | XSUB.h | 38 | ||||
| -rw-r--r-- | cv.h | 5 | ||||
| -rw-r--r-- | dist/ExtUtils-ParseXS/Changes | 4 | ||||
| -rw-r--r-- | dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm | 42 | ||||
| -rw-r--r-- | dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm | 14 | ||||
| -rw-r--r-- | dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t | 3 | ||||
| -rw-r--r-- | dump.c | 2 | ||||
| -rw-r--r-- | embed.fnc | 8 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | ext/B/B.xs | 4 | ||||
| -rw-r--r-- | ext/Devel-Peek/t/Peek.t | 2 | ||||
| -rw-r--r-- | ext/DynaLoader/dlutils.c | 4 | ||||
| -rw-r--r-- | ext/XS-APItest/XSUB-redefined-macros.xs | 2 | ||||
| -rw-r--r-- | ext/re/re.pm | 2 | ||||
| -rw-r--r-- | ext/re/re.xs | 4 | ||||
| -rw-r--r-- | op.c | 4 | ||||
| -rw-r--r-- | pad.c | 4 | ||||
| -rw-r--r-- | perl.c | 9 | ||||
| -rw-r--r-- | perl.h | 20 | ||||
| -rw-r--r-- | perlio.c | 16 | ||||
| -rw-r--r-- | pod/perldiag.pod | 6 | ||||
| -rw-r--r-- | proto.h | 15 | ||||
| -rw-r--r-- | sv.c | 15 | ||||
| -rw-r--r-- | sv.h | 2 | ||||
| -rw-r--r-- | util.c | 115 | ||||
| -rw-r--r-- | util.h | 58 |
26 files changed, 332 insertions, 68 deletions
@@ -170,6 +170,17 @@ is a lexical $_ in scope. #else # define dXSARGS \ dSP; dAXMARK; dITEMS +/* These 2 macros are specialized replacements for dXSARGS macro. They may be + replaced with dXSARGS if no version checking is desired. The 2 macros factor + out common code in every BOOT XSUB. Computation of vars mark and items will + optimize away in most BOOT functions. Var ax can never be optimized away + since BOOT must return &PL_sv_yes by default from xsubpp */ +# define dXSBOOTARGSXSAPIVERCHK \ + I32 ax = XS_BOTHVERSION_POPMARK_BOOTCHECK; \ + SV **mark = PL_stack_base + ax; dSP; dITEMS +# define dXSBOOTARGSAPIVERCHK \ + I32 ax = XS_APIVERSION_POPMARK_BOOTCHECK; \ + SV **mark = PL_stack_base + ax; dSP; dITEMS #endif #define dXSTARG SV * const targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \ @@ -325,13 +336,36 @@ Rethrows a previously caught exception. See L<perlguts/"Exception Handling">. #ifdef XS_VERSION # define XS_VERSION_BOOTCHECK \ - Perl_xs_version_bootcheck(aTHX_ items, ax, STR_WITH_LEN(XS_VERSION)) + Perl_xs_handshake(HS_KEY(FALSE, "", XS_VERSION), HS_CXT, items, ax, XS_VERSION) #else # define XS_VERSION_BOOTCHECK #endif #define XS_APIVERSION_BOOTCHECK \ - Perl_xs_apiversion_bootcheck(ST(0), STR_WITH_LEN("v" PERL_API_VERSION_STRING)) + Perl_xs_handshake(HS_KEY(FALSE, "v" PERL_API_VERSION_STRING, ""), HS_CXT, items, ax, "v" PERL_API_VERSION_STRING) +/* public API, this is a combination of XS_VERSION_BOOTCHECK and + XS_APIVERSION_BOOTCHECK in 1, and is backportable */ +#ifdef XS_VERSION +# define XS_BOTHVERSION_BOOTCHECK \ + Perl_xs_handshake(HS_KEY(FALSE, "v" PERL_API_VERSION_STRING, XS_VERSION) \ + , HS_CXT, items, ax, "v" PERL_API_VERSION_STRING, XS_VERSION) +#else +/* should this be a #error? if you want both checked, you better supply XS_VERSION right? */ +# define XS_BOTHVERSION_BOOTCHECK XS_APIVERSION_BOOTCHECK +#endif + +/* private API */ +# define XS_APIVERSION_POPMARK_BOOTCHECK \ + Perl_xs_handshake(HS_KEY(TRUE, "v" PERL_API_VERSION_STRING, "") \ + , HS_CXT, "v" PERL_API_VERSION_STRING) +#ifdef XS_VERSION +# define XS_BOTHVERSION_POPMARK_BOOTCHECK \ + Perl_xs_handshake(HS_KEY(TRUE, "v" PERL_API_VERSION_STRING, XS_VERSION) \ + , HS_CXT, "v" PERL_API_VERSION_STRING, XS_VERSION) +#else +/* should this be a #error? if you want both checked, you better supply XS_VERSION right? */ +# define XS_BOTHVERSION_POPMARK_BOOTCHECK XS_APIVERSION_POPMARK_BOOTCHECK +#endif #ifdef NO_XSLOCKS # define dXCPT dJMPENV; int rEtV = 0 @@ -75,9 +75,8 @@ See L<perlguts/Autoloading with XSUBs>. #else # define CvPADLIST_set(sv, padlist) (CvPADLIST(sv) = (padlist)) #endif -/* CvRESERVED is a placeholder and will be going away soon */ -#define CvRESERVED(sv) *(assert_(CvISXSUB((CV*)(sv))) \ - &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_reserved)) +#define CvHSCXT(sv) *(assert_(CvISXSUB((CV*)(sv))) \ + &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_hscxt)) #ifdef DEBUGGING # if PTRSIZE == 8 # define PoisonPADLIST(sv) \ diff --git a/dist/ExtUtils-ParseXS/Changes b/dist/ExtUtils-ParseXS/Changes index 41966fd1cc..233a8a1302 100644 --- a/dist/ExtUtils-ParseXS/Changes +++ b/dist/ExtUtils-ParseXS/Changes @@ -1,5 +1,9 @@ Revision history for Perl extension ExtUtils::ParseXS. +3.26 - not released yet + - Support added for XS handshake API introduced in 5.21.6. + - backported S_croak_xs_usage optimized on threaded builds + 3.24 - Wed Mar 5 18:20:00 CET 2014 - Native Android build fixes - More lenient syntax for embedded TYPEMAP blocks in XS: diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm index d63bcc682f..70a6445b16 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -891,11 +891,13 @@ EOF print Q(<<"EOF"); #XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */ #XS_EXTERNAL(boot_$self->{Module_cname}) -EOF - - print Q(<<"EOF"); #[[ +##if PERL_VERSION_LE(5, 21, 5) # dVAR; dXSARGS; +##else +# dVAR; ${\($self->{WantVersionChk} ? + 'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')} +##endif EOF #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const @@ -916,15 +918,26 @@ EOF print Q(<<"EOF"); # PERL_UNUSED_VAR(cv); /* -W */ # PERL_UNUSED_VAR(items); /* -W */ -##ifdef XS_APIVERSION_BOOTCHECK +EOF + + if( $self->{WantVersionChk}){ + print Q(<<"EOF") ; +##if PERL_VERSION_LE(5, 21, 5) +# XS_VERSION_BOOTCHECK; +## ifdef XS_APIVERSION_BOOTCHECK # XS_APIVERSION_BOOTCHECK; +## endif ##endif + EOF + } else { + print Q(<<"EOF") ; +##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK) +# XS_APIVERSION_BOOTCHECK; +##endif - print Q(<<"EOF") if $self->{WantVersionChk}; -# XS_VERSION_BOOTCHECK; -# EOF + } print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; # { @@ -960,14 +973,15 @@ EOF } print Q(<<'EOF'); -##if (PERL_REVISION == 5 && PERL_VERSION >= 9) -# if (PL_unitcheckav) -# call_list(PL_scopestack_ix, PL_unitcheckav); -##endif -EOF - - print Q(<<"EOF"); +##if PERL_VERSION_LE(5, 21, 5) +## if PERL_VERSION_GE(5, 9, 0) +# if (PL_unitcheckav) +# call_list(PL_scopestack_ix, PL_unitcheckav); +## endif # XSRETURN_YES; +##else +# Perl_xs_boot_epilog(aTHX_ ax); +##endif #]] # EOF diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm index 1a1f171d9c..7f957595fd 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm @@ -453,10 +453,10 @@ EOF /* prototype to pass -Wmissing-prototypes */ STATIC void -S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params); +S_croak_xs_usage(const CV *const cv, const char *const params); STATIC void -S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) +S_croak_xs_usage(const CV *const cv, const char *const params) { const GV *const gv = CvGV(cv); @@ -468,21 +468,17 @@ S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) - Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); + Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params); else - Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); + Perl_croak_nocontext("Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ - Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); + Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); } } #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE -#ifdef PERL_IMPLICIT_CONTEXT -#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b) -#else #define croak_xs_usage S_croak_xs_usage -#endif #endif diff --git a/dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t b/dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t index 0d11c47841..da039205e3 100644 --- a/dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t +++ b/dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t @@ -2,7 +2,7 @@ use strict; use warnings; $| = 1; -use Test::More tests => 5; +use Test::More tests => 4; use File::Spec; use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); use ExtUtils::ParseXS::Utilities qw( @@ -13,7 +13,6 @@ use PrimitiveCapture; my @statements = ( '#ifndef PERL_UNUSED_VAR', '#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE', - '#ifdef PERL_IMPLICIT_CONTEXT', '#ifdef newXS_flags', ); @@ -1990,7 +1990,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } } else - Perl_dump_indent(aTHX_ level, file, " RESERVED = 0x%p\n", CvRESERVED(sv)); + Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv)); { const CV * const outside = CvOUTSIDE(sv); Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n", @@ -275,6 +275,7 @@ Anprd |void |croak_xs_usage |NN const CV *const cv \ |NN const char *const params npr |void |croak_no_mem nprX |void |croak_popstack +fnprx |void |noperl_die|NN const char* pat|... #if defined(WIN32) norx |void |win32_croak_not_implemented|NN const char * fname #endif @@ -2695,11 +2696,8 @@ Apo |void* |my_cxt_init |NN int *index|size_t size : XS_VERSION_BOOTCHECK Xpo |void |xs_version_bootcheck|U32 items|U32 ax|NN const char *xs_p \ |STRLEN xs_len -: This function is an implementation detail. The public API for this is -: XS_APIVERSION_BOOTCHECK -Xpon |void |xs_apiversion_bootcheck|NN SV *module|NN const char *api_p \ - |STRLEN api_len - +Xpon |I32 |xs_handshake |const U32 key|NN void * v_my_perl|... +Xp |void |xs_boot_epilog |const U32 ax #ifndef HAS_STRLCAT Apnod |Size_t |my_strlcat |NULLOK char *dst|NULLOK const char *src|Size_t size #endif @@ -1257,6 +1257,7 @@ #define newSVavdefelem(a,b,c) Perl_newSVavdefelem(aTHX_ a,b,c) #define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g) #define nextargv(a,b) Perl_nextargv(aTHX_ a,b) +#define noperl_die Perl_noperl_die #define oopsAV(a) Perl_oopsAV(aTHX_ a) #define oopsHV(a) Perl_oopsHV(aTHX_ a) #define op_const_sv(a,b) Perl_op_const_sv(aTHX_ a,b) @@ -1318,6 +1319,7 @@ #define wait4pid(a,b,c) Perl_wait4pid(aTHX_ a,b,c) #define watch(a) Perl_watch(aTHX_ a) #define write_to_stderr(a) Perl_write_to_stderr(aTHX_ a) +#define xs_boot_epilog(a) Perl_xs_boot_epilog(aTHX_ a) #define yyerror(a) Perl_yyerror(aTHX_ a) #define yyerror_pv(a,b) Perl_yyerror_pv(aTHX_ a,b) #define yyerror_pvn(a,b,c) Perl_yyerror_pvn(aTHX_ a,b,c) diff --git a/ext/B/B.xs b/ext/B/B.xs index e4707787d3..f5c332df7c 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1947,10 +1947,10 @@ CvPADLIST(cv) #endif SV * -CvRESERVED(cv) +CvHSCXT(cv) B::CV cv CODE: - RETVAL = newSViv(CvISXSUB(cv) ? PTR2IV(CvRESERVED(cv)) : 0); + RETVAL = newSVuv(CvISXSUB(cv) ? PTR2UV(CvHSCXT(cv)) : 0); OUTPUT: RETVAL diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 57dbe41da7..118b35ef6a 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -689,7 +689,7 @@ do_test('constant subroutine', FLAGS = 0x100c # $] >= 5.015 OUTSIDE_SEQ = 0 PADLIST = 0x0 # $] < 5.021006 - RESERVED = $ADDR # $] >= 5.021006 + HSCXT = $ADDR # $] >= 5.021006 OUTSIDE = 0x0 \\(null\\)'); do_test('isUV should show on PVMG', diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 70703b15f4..cd489e5129 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -20,6 +20,10 @@ #endif #define MY_CXT_KEY "DynaLoader::_guts" XS_VERSION +/* disable version checking since DynaLoader can't be DynaLoaded */ +#undef dXSBOOTARGSXSAPIVERCHK +#define dXSBOOTARGSXSAPIVERCHK dXSARGS + typedef struct { SV* x_dl_last_error; /* pointer to allocated memory for last error message */ diff --git a/ext/XS-APItest/XSUB-redefined-macros.xs b/ext/XS-APItest/XSUB-redefined-macros.xs index 275f380d94..ad3132947d 100644 --- a/ext/XS-APItest/XSUB-redefined-macros.xs +++ b/ext/XS-APItest/XSUB-redefined-macros.xs @@ -4,7 +4,7 @@ /* We have to be in a different .xs so that we can do this: */ #undef XS_VERSION -#define XS_VERSION "" +#define XS_VERSION " " #undef PERL_API_VERSION_STRING #define PERL_API_VERSION_STRING "1.0.16" #include "XSUB.h" diff --git a/ext/re/re.pm b/ext/re/re.pm index 511c1c4b9a..7c2044e72a 100644 --- a/ext/re/re.pm +++ b/ext/re/re.pm @@ -4,7 +4,7 @@ package re; use strict; use warnings; -our $VERSION = "0.27"; +our $VERSION = "0.28"; our @ISA = qw(Exporter); our @EXPORT_OK = ('regmust', qw(is_regexp regexp_pattern diff --git a/ext/re/re.xs b/ext/re/re.xs index 2be0773ffb..444997b4ac 100644 --- a/ext/re/re.xs +++ b/ext/re/re.xs @@ -8,6 +8,10 @@ #include "XSUB.h" #include "re_comp.h" +#undef dXSBOOTARGSXSAPIVERCHK +/* skip API version checking due to different interp struct size but, + this hack is until #123007 is resolved */ +#define dXSBOOTARGSXSAPIVERCHK dXSARGS START_EXTERN_C @@ -8852,7 +8852,11 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */ CvISXSUB_on(cv); CvXSUB(cv) = subaddr; +#ifndef PERL_IMPLICIT_CONTEXT + CvHSCXT(cv) = &PL_stack_sp; +#else PoisonPADLIST(cv); +#endif if (name) process_special_blocks(0, name, gv, cv); @@ -504,8 +504,8 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) Safefree(padlist); CvPADLIST_set(&cvbody, NULL); } - else if (CvISXSUB(&cvbody)) /* future union */ - CvRESERVED(&cvbody) = NULL; + else if (CvISXSUB(&cvbody)) + CvHSCXT(&cvbody) = NULL; /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */ @@ -5035,6 +5035,15 @@ read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) return 1; } +/* removes boilerplate code at the end of each boot_Module xsub */ +void +Perl_xs_boot_epilog(pTHX_ const U32 ax) +{ + if (PL_unitcheckav) + call_list(PL_scopestack_ix, PL_unitcheckav); + XSRETURN_YES; +} + /* * Local variables: * c-indentation-style: bsd @@ -5495,6 +5495,26 @@ END_EXTERN_C #undef PERLVARI #undef PERLVARIC +#if !defined(MULTIPLICITY) +/* Set up PERLVAR macros for populating structs */ +# define PERLVAR(prefix,var,type) type prefix##var; +/* 'var' is an array of length 'n' */ +# define PERLVARA(prefix,var,n,type) type prefix##var[n]; +/* initialize 'var' to init' */ +# define PERLVARI(prefix,var,type,init) type prefix##var; +/* like PERLVARI, but make 'var' a const */ +# define PERLVARIC(prefix,var,type,init) type prefix##var; + +/* this is never instantiated, is it just used for sizeof(struct PerlHandShakeInterpreter) */ +struct PerlHandShakeInterpreter { +# include "intrpvar.h" +}; +# undef PERLVAR +# undef PERLVARA +# undef PERLVARI +# undef PERLVARIC +#endif + START_EXTERN_C /* dummy variables that hold pointers to both runops functions, thus forcing @@ -5217,6 +5217,22 @@ vfprintf(FILE *fd, char *pat, char *args) #endif +/* print a failure format string message to stderr and fail exit the process + using only libc without depending on any perl data structures being + initialized. +*/ + +void +Perl_noperl_die(const char* pat, ...) +{ + va_list(arglist); + PERL_ARGS_ASSERT_NOPERL_DIE; + va_start(arglist, pat); + vfprintf(stderr, pat, arglist); + va_end(arglist); + exit(1); +} + /* * Local variables: * c-indentation-style: bsd diff --git a/pod/perldiag.pod b/pod/perldiag.pod index c4264b44d4..86a525b848 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -549,6 +549,12 @@ copiable. (P) When starting a new thread or returning values from a thread, Perl encountered an invalid data type. +=item BOOT:: Invalid handshake key got %X needed %X, binaries are mismatched + +(P) A dynamic loading library C<.so> or C<.dll> was being loaded into the +process that was built against a different build of perl than the said +library was compiled against. + =item Buffer overflow in prime_env_iter: %s (W internal) A warning peculiar to VMS. While Perl was preparing to @@ -3164,6 +3164,13 @@ PERL_CALLCONV char* Perl_ninstr(const char* big, const char* bigend, const char* #define PERL_ARGS_ASSERT_NINSTR \ assert(big); assert(bigend); assert(little); assert(lend) +PERL_CALLCONV_NO_RET void Perl_noperl_die(const char* pat, ...) + __attribute__noreturn__ + __attribute__format__(__printf__,1,2) + __attribute__nonnull__(1); +#define PERL_ARGS_ASSERT_NOPERL_DIE \ + assert(pat) + PERL_CALLCONV int Perl_nothreadhook(pTHX); PERL_CALLCONV OP* Perl_oopsAV(pTHX_ OP* o) __attribute__warn_unused_result__ @@ -5153,11 +5160,11 @@ PERL_CALLCONV void Perl_write_to_stderr(pTHX_ SV* msv) #define PERL_ARGS_ASSERT_WRITE_TO_STDERR \ assert(msv) -PERL_CALLCONV void Perl_xs_apiversion_bootcheck(SV *module, const char *api_p, STRLEN api_len) - __attribute__nonnull__(1) +PERL_CALLCONV void Perl_xs_boot_epilog(pTHX_ const U32 ax); +PERL_CALLCONV I32 Perl_xs_handshake(const U32 key, void * v_my_perl, ...) __attribute__nonnull__(2); -#define PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK \ - assert(module); assert(api_p) +#define PERL_ARGS_ASSERT_XS_HANDSHAKE \ + assert(v_my_perl) PERL_CALLCONV void Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, STRLEN xs_len) __attribute__nonnull__(pTHX_3); @@ -13631,13 +13631,14 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) : gv_dup(CvGV(sstr), param); if (!CvISXSUB(sstr)) { - if(CvPADLIST(sstr)) - CvPADLIST_set(dstr, padlist_dup(CvPADLIST(sstr), param)); - else - CvPADLIST_set(dstr, NULL); - } else { /* future union here */ - CvRESERVED(dstr) = NULL; - } + PADLIST * padlist = CvPADLIST(sstr); + if(padlist) + padlist = padlist_dup(padlist, param); + CvPADLIST_set(dstr, padlist); + } else +/* unthreaded perl can't sv_dup so we dont support unthreaded's CvHSCXT */ + PoisonPADLIST(dstr); + CvOUTSIDE(dstr) = CvWEAKOUTSIDE(sstr) ? cv_dup( CvOUTSIDE(dstr), param) @@ -594,7 +594,7 @@ typedef U32 cv_flags_t; char * xcv_file; \ union { \ PADLIST * xcv_padlist; \ - void * xcv_reserved; \ + void * xcv_hscxt; \ } xcv_padlist_u; \ CV * xcv_outside; \ U32 xcv_outside_seq; /* the COP sequence (at the point of our \ @@ -5331,6 +5331,108 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ #endif /* PERL_IMPLICIT_CONTEXT */ + +/* The meaning of the varargs is determined U32 key arg. This is not a format + string. The U32 key is assembled with HS_KEY. + + v_my_perl arg is "PerlInterpreter * my_perl" if PERL_IMPLICIT_CONTEXT and + otherwise "CV * cv" (boot xsub's CV *). v_my_perl will catch where a threaded + future perl526.dll calling IO.dll for example, and IO.dll was linked with + threaded perl524.dll, and both perl526.dll and perl524.dll are in %PATH and + the Win32 DLL loader sucessfully can load IO.dll into the process but + simultaniously it loaded a interp of a different version into the process, + and XS code will naturally pass SV*s created by perl524.dll for perl526.dll + to use through perl526.dll's my_perl->Istack_base. + + v_my_perl (v=void) can not be the first arg since then key will be out of + place in a threaded vs non-threaded mixup and analyzing the key number's + bitfields won't reveal the problem since it will be a valid key + (unthreaded perl) on interp side, but croak reports the XS mod's key as + gibberish (it is really my_perl ptr) (threaded XS mod), or if threaded perl + and unthreaded XS module, threaded perl will look at uninit C stack or uninit + register to get var key (remember it assumes 1st arg is interp cxt). + +Perl_xs_handshake(U32 key, void * v_my_perl, [U32 items, U32 ax], [char * api_version], [char * xs_version]) */ +I32 +Perl_xs_handshake(const U32 key, void * v_my_perl, ...) +{ + va_list args; + U32 items, ax; +#ifdef PERL_IMPLICIT_CONTEXT + dTHX; +#endif + PERL_ARGS_ASSERT_XS_HANDSHAKE; + va_start(args, v_my_perl); + + if((key & HSm_KEY_MATCH) != (HS_KEY(FALSE, "", "") & HSm_KEY_MATCH)) + noperl_die("BOOT:: Invalid handshake key got %X needed %X" + ", binaries are mismatched", (key & HSm_KEY_MATCH) + , (HS_KEY(FALSE, "", "") & HSm_KEY_MATCH)); +/* try to catch where a 2nd threaded perl interp DLL is loaded into a process + by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the + 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so + dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub + passed to the XS DLL */ + { + void * got; + void * need; +#ifdef PERL_IMPLICIT_CONTEXT + tTHX xs_interp = (tTHX)v_my_perl; + got = xs_interp; + need = my_perl; +#else +/* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is + loaded into a process by a XS DLL built by an unthreaded perl522.dll perl, + but the DynaLoder/Perl that started the process and loaded the XS DLL is + unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *) + through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's + location in the unthreaded perl binary) stored in CV * to figure out if this + Perl_xs_handshake was called by the same pp_entersub */ + CV* cv = (CV*)v_my_perl; + SV *** xs_spp = (SV***)CvHSCXT(cv); + got = xs_spp; + need = &PL_stack_sp; +#endif + if(got != need)/* recycle branch and string from above */ + noperl_die("BOOT:: Invalid handshake key got %X needed %X" + ", binaries are mismatched", got, need); + } + + if(key & HSf_POPMARK) { + ax = POPMARK; + { SV **mark = PL_stack_base + ax++; + { dSP; + items = (I32)(SP - MARK); + } + } + } else { + items = va_arg(args, U32); + ax = va_arg(args, U32); + } + { + U32 apiverlen; + assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX); + if(apiverlen = HS_GETAPIVERLEN(key)) { + char * api_p = va_arg(args, char*); + if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1 + || memNE(api_p, "v" PERL_API_VERSION_STRING, + sizeof("v" PERL_API_VERSION_STRING)-1)) + Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s", + api_p, SVfARG(PL_stack_base[ax + 0]), + "v" PERL_API_VERSION_STRING); + } + } + { + U32 xsverlen; + assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX); + if(xsverlen = HS_GETXSVERLEN(key)) + Perl_xs_version_bootcheck(aTHX_ + items, ax, va_arg(args, char*), xsverlen); + } + va_end(args); + return ax; +} + void Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, STRLEN xs_len) @@ -5379,19 +5481,6 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, } } -void -Perl_xs_apiversion_bootcheck(SV *module, const char *api_p, - STRLEN api_len) -{ - PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK; - - if(api_len != sizeof("v" PERL_API_VERSION_STRING)-1 - || memNE(api_p, "v" PERL_API_VERSION_STRING, sizeof("v" PERL_API_VERSION_STRING)-1)) { - Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s", - api_p, SVfARG(module), "v" PERL_API_VERSION_STRING); - } -} - /* =for apidoc my_strlcat @@ -163,6 +163,64 @@ typedef struct { #endif /* USE_C_BACKTRACE */ +/* Use a packed 32 bit constant "key" to start the handshake. The key defines + ABI compatibility, and how to process the vararg list. + + Note, some bits may be taken from INTRPSIZE (but then a simple x86 AX register + can't be used to read it) and 4 bits from API version len can also be taken, + since v00.00.00 is 9 bytes long. XS version length should not have any bits + taken since XS_VERSION lengths can get quite long since they are user + selectable. These spare bits allow for additional features for the varargs + stuff or ABI compat test flags in the future. +*/ +#define HSm_APIVERLEN 0x0000003F /* perl version string won't be more than 63 chars */ +#define HS_APIVERLEN_MAX HSm_APIVERLEN +#define HSm_XSVERLEN 0x0000FF00 /* if 0, not present, dont check, die if over 255*/ +#define HS_XSVERLEN_MAX 0xFF +#define HSf_POPMARK 0x00000040 /* popmark mode or you must supply ax and items */ +#define HSf_IMP_CXT 0x00000080 /* ABI, threaded/PERL_IMPLICIT_CONTEXT, pTHX_ present */ +#define HSm_INTRPSIZE 0xFFFF0000 /* ABI, interp struct size */ +/* a mask where these bits must always match between a XS mod and interp */ +/* and maybe HSm_APIVERLEN one day if Perl_xs_apiversion_bootcheck is changed to a memcmp */ +#define HSm_KEY_MATCH (HSm_INTRPSIZE|HSf_IMP_CXT) + + +#define HS_GETINTERPSIZE(key) ((key) >> 16) +/* if in the future "" and NULL must be separated, XSVERLEN would be 0 +means arg not present, 1 is empty string/null byte */ +/* (((key) & 0x0000FF00) >> 8) is less efficient on Visual C */ +#define HS_GETXSVERLEN(key) ((key) >> 8 & 0xFF) +#define HS_GETAPIVERLEN(key) ((key) & HSm_APIVERLEN) + +/* internal to util.h macro to create a packed handshake key, all args must be constants */ +/* U32 return = (U16 interpsize, bool cxt, bool popmark, U6 (SIX!) apiverlen, U8 xsverlen) */ +#define HS_KEYp(interpsize, cxt, popmark, apiverlen, xsverlen) \ + (((interpsize) << 16) \ + | ((xsverlen) > HS_XSVERLEN_MAX \ + ? (Perl_croak_nocontext("panic: handshake overflow"), HS_XSVERLEN_MAX) \ + : (xsverlen) << 8) \ + | (cBOOL(cxt) ? HSf_IMP_CXT : 0) \ + | (cBOOL(popmark) ? HSf_POPMARK : 0) \ + | ((apiverlen) > HS_APIVERLEN_MAX \ + ? (Perl_croak_nocontext("panic: handshake overflow"), HS_APIVERLEN_MAX) \ + : (apiverlen))) +/* overflows above will optimize away unless they will execute */ + +/* public macro for core usage to create a packed handshake key but this is + not public API. This more friendly version already collected all ABI info */ +/* U32 return = (bool popmark, "litteral_string_api_ver", "litteral_string_xs_ver") */ +#ifdef PERL_IMPLICIT_CONTEXT +# define HS_KEY(popmark, apiver, xsver) \ + HS_KEYp(sizeof(PerlInterpreter), TRUE, popmark, \ + sizeof("" apiver "")-1, sizeof("" xsver "")-1) +# define HS_CXT aTHX +#else +# define HS_KEY(popmark, apiver, xsver) \ + HS_KEYp(sizeof(struct PerlHandShakeInterpreter), FALSE, popmark, \ + sizeof("" apiver "")-1, sizeof("" xsver "")-1) +# define HS_CXT cv +#endif + /* * Local variables: * c-indentation-style: bsd |