add filename handling to xs handshake
authorDaniel Dragan <bulk88@hotmail.com>
Thu, 13 Nov 2014 06:59:06 +0000 (01:59 -0500)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 13 Nov 2014 12:41:46 +0000 (04:41 -0800)
- this improves the error message on ABI incompatibility, per
  [perl #123136]
- reduce the number of gv_fetchfile calls in newXS over registering many
  XSUBs
- "v" was not stripped from PERL_API_VERSION_STRING since string
  "vX.XX.X\0", a typical version number is 8 bytes long, and aligned to
  4/8 by most compilers in an image. A double digit maint release is
  extremely unlikely.
- newXS_deffile saves on machine code in bootstrap functions by not passing
  arg filename
- move newXS to where the rest of the newXS*()s live
- move the "no address" panic closer to the start to get it out of the way
  sooner flow wise (it nothing to do with var gv or cv)
- move CvANON_on to not check var name twice
- change die message to use %p, more efficient on 32 ptr/64 IV platforms
  see ML post "about commit "util.c: fix comiler warnings""
- vars cv/xs_spp (stack pointer pointer)/xs_interp exist for inspection by
  a C debugger in an unoptimized build

15 files changed:
XSUB.h
dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm
embed.fnc
embed.h
embedvar.h
ext/DynaLoader/dlutils.c
ext/re/re.xs
intrpvar.h
op.c
pod/perldiag.pod
proto.h
sv.c
util.c
util.h

diff --git a/XSUB.h b/XSUB.h
index 547cd46..8e38df2 100644 (file)
--- a/XSUB.h
+++ b/XSUB.h
@@ -170,16 +170,23 @@ 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 */
+/* These 3 macros are replacements for dXSARGS macro only in bootstrap.
+   They 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.
+   Note these macros are not drop in replacements for dXSARGS since they set
+   PL_xsubfilename. */
 #  define dXSBOOTARGSXSAPIVERCHK  \
-       I32 ax = XS_BOTHVERSION_POPMARK_BOOTCHECK;      \
+       I32 ax = XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK;    \
        SV **mark = PL_stack_base + ax; dSP; dITEMS
 #  define dXSBOOTARGSAPIVERCHK  \
-       I32 ax = XS_APIVERSION_POPMARK_BOOTCHECK;       \
+       I32 ax = XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK;     \
+       SV **mark = PL_stack_base + ax; dSP; dITEMS
+/* dXSBOOTARGSNOVERCHK has no API in xsubpp to choose it so do
+#undef dXSBOOTARGSXSAPIVERCHK
+#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK */
+#  define dXSBOOTARGSNOVERCHK  \
+       I32 ax = XS_SETXSUBFN_POPMARK;  \
        SV **mark = PL_stack_base + ax; dSP; dITEMS
 #endif
 
@@ -336,37 +343,58 @@ Rethrows a previously caught exception.  See L<perlguts/"Exception Handling">.
 
 #ifdef XS_VERSION
 #  define XS_VERSION_BOOTCHECK                                         \
-    Perl_xs_handshake(HS_KEY(FALSE, "", XS_VERSION), HS_CXT, items, ax, XS_VERSION)
+    Perl_xs_handshake(HS_KEY(FALSE, FALSE, "", XS_VERSION), HS_CXT, __FILE__,  \
+        items, ax, XS_VERSION)
 #else
 #  define XS_VERSION_BOOTCHECK
 #endif
 
 #define XS_APIVERSION_BOOTCHECK                                                \
-    Perl_xs_handshake(HS_KEY(FALSE, "v" PERL_API_VERSION_STRING, ""), HS_CXT, items, ax, "v" PERL_API_VERSION_STRING)
+    Perl_xs_handshake(HS_KEY(FALSE, FALSE, "v" PERL_API_VERSION_STRING, ""),   \
+        HS_CXT, __FILE__, 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)
+    Perl_xs_handshake(HS_KEY(FALSE, FALSE, "v" PERL_API_VERSION_STRING, XS_VERSION),   \
+        HS_CXT, __FILE__, 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)
+#define XS_APIVERSION_POPMARK_BOOTCHECK                                        \
+    Perl_xs_handshake(HS_KEY(FALSE, TRUE, "v" PERL_API_VERSION_STRING, ""),    \
+        HS_CXT, __FILE__, "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)
+    Perl_xs_handshake(HS_KEY(FALSE, TRUE, "v" PERL_API_VERSION_STRING, XS_VERSION),    \
+        HS_CXT, __FILE__, "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
 
+#define XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK                              \
+    Perl_xs_handshake(HS_KEY(TRUE, TRUE, "v" PERL_API_VERSION_STRING, ""),     \
+        HS_CXT, __FILE__, "v" PERL_API_VERSION_STRING)
+#ifdef XS_VERSION
+#  define XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK                             \
+    Perl_xs_handshake(HS_KEY(TRUE, TRUE, "v" PERL_API_VERSION_STRING, XS_VERSION),\
+        HS_CXT, __FILE__, "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_SETXSUBFN_POPMARK_BOOTCHECK XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK
+#endif
+
+/* For a normal bootstrap without API or XS version checking.
+   Useful for static XS modules or debugging/testing scenarios.
+   If this macro gets heavily used in the future, it should separated into
+   a separate function independent of Perl_xs_handshake for efficiency */
+#define XS_SETXSUBFN_POPMARK \
+    Perl_xs_handshake(HS_KEY(TRUE, TRUE, "", "") | HSf_NOCHK, HS_CXT, __FILE__)
+
 #ifdef NO_XSLOCKS
 #  define dXCPT             dJMPENV; int rEtV = 0
 #  define XCPT_TRY_START    JMPENV_PUSH(rEtV); if (rEtV == 0)
index 70a6445..75feda5 100644 (file)
@@ -797,12 +797,15 @@ EOF
 #
 EOF
 
-    $self->{newXS} = "newXS";
     $self->{proto} = "";
-
+    unless($self->{ProtoThisXSUB}) {
+      $self->{newXS} = "newXS_deffile";
+      $self->{file} = "";
+    }
+    else {
     # Build the prototype string for the xsub
-    if ($self->{ProtoThisXSUB}) {
       $self->{newXS} = "newXSproto_portable";
+      $self->{file} = ", file";
 
       if ($self->{ProtoThisXSUB} eq 2) {
         # User has specified empty prototype
@@ -831,14 +834,14 @@ EOF
       foreach my $xname (sort keys %{ $self->{XsubAliases} }) {
         my $value = $self->{XsubAliases}{$xname};
         push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
-#        cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}, file$self->{proto});
+#        cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
 #        XSANY.any_i32 = $value;
 EOF
       }
     }
     elsif (@{ $self->{Attributes} }) {
       push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
-#        cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});
+#        cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
 #        apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0);
 EOF
     }
@@ -847,18 +850,18 @@ EOF
         my $value = $self->{Interfaces}{$yname};
         $yname = "$self->{Package}\::$yname" unless $yname =~ /::/;
         push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
-#        cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}, file$self->{proto});
+#        cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
 #        $self->{interface_macro_set}(cv,$value);
 EOF
       }
     }
-    elsif($self->{newXS} eq 'newXS'){ # work around P5NCI's empty newXS macro
+    elsif($self->{newXS} eq 'newXS_deffile'){ # work around P5NCI's empty newXS macro
       push(@{ $self->{InitFileCode} },
-       "        $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});\n");
+       "        $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
     }
     else {
       push(@{ $self->{InitFileCode} },
-       "        (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});\n");
+       "        (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
     }
   } # END 'PARAGRAPH' 'while' loop
 
@@ -876,7 +879,7 @@ EOF
     /* Making a sub named "$self->{Package}::()" allows the package */
     /* to be findable via fetchmethod(), and causes */
     /* overload::Overloaded("$self->{Package}") to return true. */
-    (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil, file$self->{proto});
+    (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto});
 MAKE_FETCHMETHOD_WORK
   }
 
@@ -1336,7 +1339,7 @@ sub OVERLOAD_handler {
       $self->{Overload} = 1 unless $self->{Overload};
       my $overload = "$self->{Package}\::(".$1;
       push(@{ $self->{InitFileCode} },
-       "        (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}, file$self->{proto});\n");
+       "        (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
     }
   }
 }
index 7f95759..30ea74f 100644 (file)
@@ -491,6 +491,12 @@ S_croak_xs_usage(const CV *const cv, const char *const params)
 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
 #endif /* !defined(newXS_flags) */
 
+#if PERL_VERSION_LE(5, 21, 5)
+#  define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file)
+#else
+#  define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b)
+#endif
+
 EOF
   return 1;
 }
index 822f2c1..9d209b7 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -989,9 +989,10 @@ Abm        |CV*    |newSUB         |I32 floor|NULLOK OP* o|NULLOK OP* proto \
                                |NULLOK OP* block
 p      |CV *   |newXS_len_flags|NULLOK const char *name|STRLEN len \
                                |NN XSUBADDR_t subaddr\
-                               |NN const char *const filename \
+                               |NULLOK const char *const filename \
                                |NULLOK const char *const proto \
                                |NULLOK SV **const_svp|U32 flags
+pX     |CV *   |newXS_deffile  |NN const char *name|NN XSUBADDR_t subaddr
 ApM    |CV *   |newXS_flags    |NULLOK const char *name|NN XSUBADDR_t subaddr\
                                |NN const char *const filename \
                                |NULLOK const char *const proto|U32 flags
@@ -2696,7 +2697,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
-Xpon   |I32    |xs_handshake   |const U32 key|NN void * v_my_perl|...
+Xpon   |I32    |xs_handshake   |const U32 key|NN void * v_my_perl\
+                               |NN const char * file| ...
 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
diff --git a/embed.h b/embed.h
index 122b3d0..938d7d3 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define newATTRSUB_x(a,b,c,d,e,f)      Perl_newATTRSUB_x(aTHX_ a,b,c,d,e,f)
 #define newSTUB(a,b)           Perl_newSTUB(aTHX_ a,b)
 #define newSVavdefelem(a,b,c)  Perl_newSVavdefelem(aTHX_ a,b,c)
+#define newXS_deffile(a,b)     Perl_newXS_deffile(aTHX_ a,b)
 #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
index 94b7a00..60c897b 100644 (file)
 #define PL_warnhook            (vTHX->Iwarnhook)
 #define PL_watchaddr           (vTHX->Iwatchaddr)
 #define PL_watchok             (vTHX->Iwatchok)
+#define PL_xsubfilename                (vTHX->Ixsubfilename)
 
 #endif /* MULTIPLICITY */
 
index cd489e5..f8b23cc 100644 (file)
@@ -22,7 +22,7 @@
 
 /* disable version checking since DynaLoader can't be DynaLoaded */
 #undef dXSBOOTARGSXSAPIVERCHK
-#define dXSBOOTARGSXSAPIVERCHK dXSARGS
+#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK
 
 typedef struct {
     SV*                x_dl_last_error;        /* pointer to allocated memory for
index 444997b..9545d1d 100644 (file)
@@ -11,7 +11,7 @@
 #undef dXSBOOTARGSXSAPIVERCHK
 /* skip API version checking due to different interp struct size but,
    this hack is until #123007 is resolved */
-#define dXSBOOTARGSXSAPIVERCHK dXSARGS
+#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK
 
 START_EXTERN_C
 
index f5d8020..c8b0b8d 100644 (file)
@@ -313,6 +313,7 @@ PERLVAR(I, envgv,   GV *)
 PERLVAR(I, incgv,      GV *)
 PERLVAR(I, hintgv,     GV *)
 PERLVAR(I, origfilename, char *)
+PERLVARI(I, xsubfilename, const char *, NULL)
 PERLVAR(I, diehook,    SV *)
 PERLVAR(I, warnhook,   SV *)
 
diff --git a/op.c b/op.c
index 184f4ae..d14bdc9 100644 (file)
--- a/op.c
+++ b/op.c
@@ -8790,6 +8790,24 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
     return cv;
 }
 
+/*
+=for apidoc U||newXS
+
+Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
+
+=cut
+*/
+
+CV *
+Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
+{
+    PERL_ARGS_ASSERT_NEWXS;
+    return newXS_len_flags(
+       name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
+    );
+}
+
 CV *
 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
                 const char *const filename, const char *const proto,
@@ -8801,6 +8819,15 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
     );
 }
 
+CV *
+Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
+{
+    PERL_ARGS_ASSERT_NEWXS_DEFFILE;
+    return newXS_len_flags(
+       name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
+    );
+}
+
 CV *
 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
                           XSUBADDR_t subaddr, const char *const filename,
@@ -8811,17 +8838,16 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
     bool interleave = FALSE;
 
     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
-
+    if (!subaddr)
+       Perl_croak_nocontext("panic: no address for '%s' in '%s'",
+           name, filename ? filename : PL_xsubfilename);
     {
         GV * const gv = gv_fetchpvn(
                            name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
                            name ? len : PL_curstash ? sizeof("__ANON__") - 1:
                                sizeof("__ANON__::__ANON__") - 1,
                            GV_ADDMULTI | flags, SVt_PVCV);
-    
-        if (!subaddr)
-            Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
-    
+
         if ((cv = (name ? GvCV(gv) : NULL))) {
             if (GvCVGEN(gv)) {
                 /* just a cached method */
@@ -8856,13 +8882,22 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
                     gv_method_changed(gv); /* newXS */
             }
         }
-        if (!name)
-            CvANON_on(cv);
+
         CvGV_set(cv, gv);
-        (void)gv_fetchfile(filename);
-        CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
-                                    an external constant string */
-        assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+        if(filename) {
+            (void)gv_fetchfile(filename);
+            assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+            if (flags & XS_DYNAMIC_FILENAME) {
+                CvDYNFILE_on(cv);
+                CvFILE(cv) = savepv(filename);
+            } else {
+            /* NOTE: not copied, as it is expected to be an external constant string */
+                CvFILE(cv) = (char *)filename;
+            }
+        } else {
+            assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
+            CvFILE(cv) = (char*)PL_xsubfilename;
+        }
         CvISXSUB_on(cv);
         CvXSUB(cv) = subaddr;
 #ifndef PERL_IMPLICIT_CONTEXT
@@ -8870,15 +8905,14 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
 #else
         PoisonPADLIST(cv);
 #endif
-    
+
         if (name)
             process_special_blocks(0, name, gv, cv);
-    }
+        else
+            CvANON_on(cv);
+    } /* <- not a conditional branch */
+
 
-    if (flags & XS_DYNAMIC_FILENAME) {
-       CvFILE(cv) = savepv(filename);
-       CvDYNFILE_on(cv);
-    }
     sv_setpv(MUTABLE_SV(cv), proto);
     if (interleave) LEAVE;
     return cv;
@@ -8907,24 +8941,6 @@ Perl_newSTUB(pTHX_ GV *gv, bool fake)
     return cv;
 }
 
-/*
-=for apidoc U||newXS
-
-Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
-static storage, as it is used directly as CvFILE(), without a copy being made.
-
-=cut
-*/
-
-CV *
-Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
-{
-    PERL_ARGS_ASSERT_NEWXS;
-    return newXS_len_flags(
-       name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
-    );
-}
-
 void
 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
 {
index 86a525b..ef29b3a 100644 (file)
@@ -549,11 +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
+=item %s: Invalid handshake key got %p needed %p, 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.
+library was compiled against. Reinstalling the XS module will likely fix this
+error.
 
 =item Buffer overflow in prime_env_iter: %s
 
diff --git a/proto.h b/proto.h
index 6d02012..4e36949 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3115,6 +3115,12 @@ PERL_CALLCONV CV*        Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const c
 #define PERL_ARGS_ASSERT_NEWXS \
        assert(subaddr); assert(filename)
 
+PERL_CALLCONV CV *     Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_NEWXS_DEFFILE \
+       assert(name); assert(subaddr)
+
 PERL_CALLCONV CV *     Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags)
                        __attribute__nonnull__(pTHX_2)
                        __attribute__nonnull__(pTHX_3);
@@ -3122,10 +3128,9 @@ PERL_CALLCONV CV *       Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
        assert(subaddr); assert(filename)
 
 PERL_CALLCONV CV *     Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, XSUBADDR_t subaddr, const char *const filename, const char *const proto, SV **const_svp, U32 flags)
-                       __attribute__nonnull__(pTHX_3)
-                       __attribute__nonnull__(pTHX_4);
+                       __attribute__nonnull__(pTHX_3);
 #define PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS       \
-       assert(subaddr); assert(filename)
+       assert(subaddr)
 
 PERL_CALLCONV void     Perl_new_collate(pTHX_ const char* newcoll);
 PERL_CALLCONV void     Perl_new_ctype(pTHX_ const char* newctype)
@@ -5161,10 +5166,11 @@ PERL_CALLCONV void      Perl_write_to_stderr(pTHX_ SV* msv)
        assert(msv)
 
 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);
+PERL_CALLCONV I32      Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
+                       __attribute__nonnull__(2)
+                       __attribute__nonnull__(3);
 #define PERL_ARGS_ASSERT_XS_HANDSHAKE  \
-       assert(v_my_perl)
+       assert(v_my_perl); assert(file)
 
 PERL_CALLCONV void     Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, STRLEN xs_len)
                        __attribute__nonnull__(pTHX_3);
diff --git a/sv.c b/sv.c
index f8d3fe2..54f939f 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -14608,6 +14608,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_incgv           = gv_dup_inc(proto_perl->Iincgv, param);
     PL_hintgv          = gv_dup_inc(proto_perl->Ihintgv, param);
     PL_origfilename    = SAVEPV(proto_perl->Iorigfilename);
+    PL_xsubfilename    = proto_perl->Ixsubfilename;
     PL_diehook         = sv_dup_inc(proto_perl->Idiehook, param);
     PL_warnhook                = sv_dup_inc(proto_perl->Iwarnhook, param);
 
diff --git a/util.c b/util.c
index e43159f..f9ca306 100644 (file)
--- a/util.c
+++ b/util.c
@@ -5352,35 +5352,38 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
    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]) */
+Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
+[U32 items, U32 ax], [char * api_version], [char * xs_version]) */
 I32
-Perl_xs_handshake(const U32 key, void * v_my_perl, ...)
+Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
 {
     va_list args;
     U32 items, ax;
+    void * got;
+    void * need;
 #ifdef PERL_IMPLICIT_CONTEXT
     dTHX;
+    tTHX xs_interp;
+#else
+    CV* cv;
+    SV *** xs_spp;
 #endif
     PERL_ARGS_ASSERT_XS_HANDSHAKE;
-    va_start(args, v_my_perl);
+    va_start(args, file);
 
-    if((key & HSm_KEY_MATCH) != (HS_KEY(FALSE, "", "") & HSm_KEY_MATCH))
-       noperl_die("BOOT:: Invalid handshake key got %"UVXf" needed %"UVXf
-                       ", binaries are mismatched",
-                        (UV)(key & HSm_KEY_MATCH),
-                       (UV)(HS_KEY(FALSE, "", "") & HSm_KEY_MATCH));
+    got = (void *)(key & HSm_KEY_MATCH);
+    need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
+    if(UNLIKELY(got != need))
+       goto bad_handshake;
 /* 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;
+    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,
@@ -5389,15 +5392,24 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, ...)
    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 %"UVXf
-                    " needed %"UVXf", binaries are mismatched",
-                    (UV)got, (UV)need);
+    cv = (CV*)v_my_perl;
+    xs_spp = (SV***)CvHSCXT(cv);
+    got = xs_spp;
+    need = &PL_stack_sp;
+#endif
+    if(UNLIKELY(got != need)) {
+       bad_handshake:/* recycle branch and string from above */
+       if(got != (void *)HSf_NOCHK)
+           noperl_die("%s: Invalid handshake key got %p"
+               " needed %p, binaries are mismatched",
+               file, got, need);
+    }
+
+    if(key & HSf_SETXSUBFN) {     /* this might be called from a module bootstrap */
+       SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
+       PL_xsubfilename = file;   /* so the old name must be restored for
+                                    additional XSUBs to register themselves */
+       (void)gv_fetchfile(file);
     }
 
     if(key & HSf_POPMARK) {
diff --git a/util.h b/util.h
index 1727233..6e63f3b 100644 (file)
--- a/util.h
+++ b/util.h
@@ -173,16 +173,21 @@ typedef struct {
    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 HSm_APIVERLEN 0x0000001F /* perl version string won't be more than 31 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
+/* uses var file to set default filename for newXS_deffile to use for CvFILE */
+#define HSf_SETXSUBFN 0x00000020
 #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 */
+/* A mask of bits in the key which must always match between a XS mod and interp.
+   Also if all ABI bits in a key are true, skip all ABI checks, it is very
+   the unlikely interp size will all 1 bits */
+/* 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 HSf_NOCHK HSm_KEY_MATCH  /* if all ABI bits are 1 in the key, dont chk */
 
 
 #define HS_GETINTERPSIZE(key) ((key) >> 16)
@@ -193,12 +198,14 @@ means arg not present, 1 is empty string/null byte */
 #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) \
+/* U32 return = (U16 interpsize, bool cxt, bool setxsubfn, bool popmark,
+   U5 (FIVE!) apiverlen, U8 xsverlen) */
+#define HS_KEYp(interpsize, cxt, setxsubfn, popmark, apiverlen, xsverlen) \
     (((interpsize)  << 16) \
     | ((xsverlen) > HS_XSVERLEN_MAX \
         ? (Perl_croak_nocontext("panic: handshake overflow"), HS_XSVERLEN_MAX) \
         : (xsverlen) << 8) \
+    | (cBOOL(setxsubfn) ? HSf_SETXSUBFN : 0) \
     | (cBOOL(cxt) ? HSf_IMP_CXT : 0) \
     | (cBOOL(popmark) ? HSf_POPMARK : 0) \
     | ((apiverlen) > HS_APIVERLEN_MAX \
@@ -208,15 +215,16 @@ means arg not present, 1 is empty string/null byte */
 
 /* 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") */
+/* U32 return = (bool setxsubfn, 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, \
+#  define HS_KEY(setxsubfn, popmark, apiver, xsver) \
+    HS_KEYp(sizeof(PerlInterpreter), TRUE, setxsubfn, 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, \
+#  define HS_KEY(setxsubfn, popmark, apiver, xsver) \
+    HS_KEYp(sizeof(struct PerlHandShakeInterpreter), FALSE, setxsubfn, popmark, \
     sizeof("" apiver "")-1, sizeof("" xsver "")-1)
 #  define HS_CXT cv
 #endif