add filename handling to xs handshake

- 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

1 files changed, 35 insertions, 23 deletions

diff --git a/util.c b/util.c
index e43159fbb0..f9ca30603f 100644
--- 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) {