op.c: slim down const_av_xsub const_sv_xsub XSUB.h: add GetXSTARG()

-don't use XSRETURN() macros, they use "unit of 1" relative offset "ax"
 and constantly reread global my_parl->Istack_base and constant rescale
 ax from unit of 1 to unit of 4/8
-don't use ST() macros for the same reason
-in const_sv_xsub() use XSTARG if its available, but just put our long
 life SV* right on the PL stack if we can't write directly into the
 caller lval SV*. Don't do "sv_setsv(sv_newmortal(), ssv);" on missing
 XSTARG branch. Don't use dXSTARG; 50% chance there will be a 2nd!!!
 secret "sv_setsv(sv_newmortal(),rval)" or "newSVsv(rval)" right after
 this XSUB anyways, so just pass our SV* on stack instead of TWO
 "sv_setsv(sv_newmortal(), ssv);" statements executing in a row.

const_av_xsub():
-if we will croak, do it ASAP once the minimum amount of data has been
 read from global memory, AV* is delivered through C function argument
 CV* cv, its not from the PL stack. So do the check and execute the
 no return before creating/reading/writing a ton of PL stack related
 global vars and C auto vars.
-GetXSTARG() and GIMME_V() both dig inside PL_op, keep them together w/o
 any func calls in between such as EXTEND() so the CC can read OP* stored
 in PL_op only once
-break apart Copy()'s overflow bounds checks so we can write a new "length"
 to global state before copying the large in bytes array, historically
 Perl has issues with letting PP end users code to keep running for severe
 overflows/heap corruption/CVE type stuff, eval{}, %SIG, tied, MG,
 sub END, etc. So do the asserts early before the actual memcpy or PUTBACK.
-handle an empty/0 elems long AV* better, don't EXTEND(0), don't call
 extern libc memcpy with 0 size
-don't keep re-reading the AV head and AV body and AvFILLp(av) over and
 over, func calls EXTEND() and memcpy() won't realloc the AV body ptr or
 modify the AvFILL member in the body struct

XSUB.h:

-add a version of dXSTARG where the user handles what to do, if parent
 frame didn't supply a SV* TARG for lval filling.  This gets rid of the
 inefficient sv_newmortal() that is forced on users when there almost
 always better faster recipie of how to create a 0, 1, or G_LIST PL
 stack retval. &PL_sv_undef, newSVpvn_flags(SVs_TEMP),
 sv_2mortal(newSViv()), return your hash key's value SV* directly, etc.
 Macro undocumented until further notice, so it can gather some unofficial
 usage/CORE usage and some opinions regarding is it good or flawed.

Author: bulk88

XSUB.h

@@ -178,9 +178,105 @@ is a lexical C<$_> in scope.
         Stack_off_t ax = XS_SETXSUBFN_POPMARK;  \
         SV **mark = PL_stack_base + ax - 1; dSP; dITEMS
 
+
+/* The internals of dXSTARG and GetXSTARG are tightly coupled (de jure)
+   with the optree and P5 lang.  In practice, dXSTARG and OPpENTERSUB_HASTARG
+   haven't been modified since they were created in 5.5.61 in commit 8a7fc0dc30
+   9/10/1999 3:22:14 PM "s/dXS_TARGET/dXSTARG/ in change#4044" and in
+   commit d30110745a 8/26/1999 11:33:01 PM "Speeding up XSUB calls up to 66%"
+
+   dXSTARG is public API, but the implementation is opaque. OPpENTERSUB_HASTARG
+   is private API. Future hypothetical enhancements that could change dXSTARG
+   are GIMME_V == G_BOOL, call_sv_lval(), XS_MULTICALL. */
+
+
 #define dXSTARG SV * const targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
                              ? PAD_SV(PL_op->op_targ) : sv_newmortal())
 
+/* GetXSTARG() is part of the interp's private API for now. It is intended
+   that in the future, it will be public API.  Timeframe is TBD.  It needs
+   more usage in PERL_CORE, to shake out potential API design flaws or CPAN XS
+   mousetraps before committing to support it publically.  Since it is private,
+   it can be renamed if needed. */
+
+#ifdef PERL_CORE
+
+/* A faster, more efficient variant of C<dXSTARG>.  Similar to the optree's
+   GETTARGET, but "specialized" for XSUBs written by core or written by CPAN.
+   The benefit of C<GetXSTARG> over C<dXSTARG> is that C<GetXSTARG> will return
+   C<NULL> if a targ C<SV *> isn't currently available and lets the user decide
+   how to go forward.  Meanwhile C<dXSTARG> will always internally call
+   C<sv_newmortal()> if a targ C<SV *> isn't available at that moment.
+   Do not evaluate this macro multiple times.  Save the result of this macro to
+   a C<SV*> var.
+
+   Just like C<dXSTARG>, the C<SV *> returned by C<GetXSTARG> may have stale
+   prior contents in it. */
+/*
+   You must test the returned value for C<NULL> and procede
+   accordingly.  Do not make any assumptions on why you did or did not get NULL
+   from this macro.  This macro is not a substitute for using L<GIMME_V>.
+   The non-NULL or NULL result of this macro has no correlation to what
+   C<@_> context, the caller PP/XS sub, has requested from your XSUB through
+   C<GIMME_V>.
+
+   Assume C<GIMME_V> can return <G_VOID> while at the same time C<GetXSTARG>
+   returns non-NULL.  Also assume C<if (!(sv = GetXSTARG()) && GIMME_V == G_SCALAR)>
+   can happen and therefore you very likely will need to allocate a new C<SV*>
+   and mortalize it.  It is discouraged and probably a bug, for an XSUB to
+   bump the C<SvREFCNT(sv)> on C<TARG> and save the C<SV*> for later use.
+   Do not make assumptions about C<TARG>'s C<SvREFCNT>, or what is the outer
+   container that really the C<SV*>.  Something else inside the interpreter
+   which is unspecified, owns C<SV* TARG>, and unspecified caller, probably
+   wants you to write into this C<SV*> as an lval, vs you doing a less
+   efficient C<sv_newmortal()>/C<sv_2mortal(newSVxxxv())>, and later on the
+   unspecified caller has to call <sv_setsv()>, and let the mortal stack dispose
+   of your short lived <SV*>.
+
+   Although this is undocumented and private to the interpreter and you may not
+   write code that is aware of this private implementation detail.  Keep in
+   mind the interpreter uses the C<SV* TARG> concept for both input and/or output
+   in various places between parts of itself and might be using C<SV* TARG> as
+   lvalue scratch pad in a loop.
+
+   Remember that the C<SV*> from C<dXSTARG> or C<GetXSTARG>, might be C<SvOK()>
+   and have stale prior contents that you need to wipe or free.  C<sv_setxxx()>
+   functions will always do this for you.  There is no guarentee the <SV*>
+   from C<dXSTARG> or C<GetXSTARG> will be set to C<undef> when you get it.
+   If you need to return C<undef>, you have 2 choices. Don't fetch and
+   don't use C<TARG>, and push C<&PL_sv_undef> on the stack.  The other choices
+   you have is to call, sorted most efficient to least efficient:
+
+   sv_setsv_undef(my_targ);       SvSETMAGIC(my_targ);
+   sv_setpv_mg(my_targ, NULL);
+   sv_setsv_mg(my_targ, NULL);
+   sv_setsv_mg(my_targ, &PL_sv_undef);  //more readable
+
+   Also consider, there is no clear guidance for this.  Do you think you the
+   PP or XS caller, that called your XSUB, if it is interested in getting a
+   C<@_> return value in the first place. Is the caller going to write it as
+   a true/false check, like C<if(do_xsub()) {0;}>, or will it write
+   C<my $result = do_xsub();> and capture your return value for future use.
+   The first probably don't set up a TARG for your to use. The 2nd probably
+   will, but there are no guarentees it will set one up ahead of time.
+
+   Returning address C<&PL_sv_undef> is much faster than C<sv_newmortal()> or
+   C<sv_set_undef()>.  C<sv_set_undef()> is faster than the caller later on
+   doing a C<sv_setsv()>.  C<sv_setsv()> has a quick bailout shortcut in it
+   if src and dest C<SV*>s are the same addr.
+
+   There is also no guarentee about what its C<SvTYPE()> is.
+   Always assume it is of type <SVt_NULL>, and it has no SV body until you
+   you test its type and possibly call C<SvUPGRADE> or <sv_setiv>/C<sv_setpvn>
+   on it.  There is no guarentee C<SvANY()> is non-NULL or C<SvANY()> contains
+   a valid address or points to initialized memory.  There is no guarentee
+   C<SvTYPE()> is at minimum C<SVt_IV> and reading C<SvIVX()> won't SEGV. */
+
+#define GetXSTARG() ((PL_op->op_private & OPpENTERSUB_HASTARG) \
+                             ? PAD_SV(PL_op->op_targ) : NULL)
+
+#endif
+
 /* Should be used before final PUSHi etc. if not in PPCODE section. */
 #define XSprePUSH (sp = PL_stack_base + ax - 1)
 

op.c

@@ -16266,39 +16266,82 @@ Perl_wrap_op_checker(pTHX_ Optype opcode,
 static void
 const_sv_xsub(pTHX_ CV* cv)
 {
+    SV * sv = MUTABLE_SV(XSANY.any_ptr);
     dXSARGS;
-    SV *const sv = MUTABLE_SV(XSANY.any_ptr);
-    PERL_UNUSED_ARG(items);
-    if (!sv) {
-        XSRETURN(0);
+    SP -= items; /* wipe incoming, this is a ... vararg on PP level */
+    /* Don't optimize/chk for G_VOID, very unlikely or caller bug
+       to reach this XSUB and discard its @_ retval. */
+    if (sv) {
+        EXTEND(SP, 1);
+        SV *const targ = GetXSTARG();
+        /* If we have it, write into it, to prevent and shortcut
+           the inevitable sv_setsv() the caller will do. */
+        if (targ) {
+            SV *const ssv = sv;
+            sv = targ;
+            sv_setsv_mg(targ, ssv);
+        }
+        PUSHs(sv);
     }
-    EXTEND(sp, 1);
-    ST(0) = sv;
-    XSRETURN(1);
+    PUTBACK; /* ret 0 or 1 SV*s */
 }
 
 static void
 const_av_xsub(pTHX_ CV* cv)
 {
-    dXSARGS;
     AV * const av = MUTABLE_AV(XSANY.any_ptr);
-    SP -= items;
+
+    if (av && SvRMAGICAL(av))
+        Perl_croak_nocontext("Magical list constants are not supported");
     assert(av);
+
+    dXSARGS;
+    SP = MARK; /* wipe all */
 #ifndef DEBUGGING
     if (!av) {
-        XSRETURN(0);
+        PUTBACK;
+        return;
     }
 #endif
-    if (SvRMAGICAL(av))
-        croak("Magical list constants are not supported");
-    if (GIMME_V != G_LIST) {
-        EXTEND(SP, 1);
-        ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
-        XSRETURN(1);
+    SSize_t av_cur = AvFILLp(av)+1;
+    /* protect PUTBACK before Copy(), in case perl's Copy()/memcpy()
+       returns execution control to PP code with longjmp(). */
+    MEM_WRAP_CHECK(av_cur, SV *);
+
+    SV * retsv;
+    U8 gm = GIMME_V;
+    if (gm != G_LIST) { /* group GIMME_V GetXSTARG so they share PL_op derefs */
+        retsv = GetXSTARG();
+        if (retsv)
+            sv_setiv_mg(retsv, (IV)av_cur);
+        else
+            retsv = sv_2mortal(newSViv((IV)av_cur));
+    }
+    else if(av_cur == 0) { /* empty array */
+        PUTBACK;
+        return;
+    }
+    else
+        retsv = NULL;
+    EXTEND(SP, retsv ? 1 : av_cur);
+    SP++; /* move to ST(0), returning atleast 1 elem */
+    if (retsv) {
+        SETs(retsv);
+        PUTBACK;
+    }
+    else {
+        SV ** avarr = AvARRAY(av);
+        SV ** sp_start = SP;
+        perl_assert_ptr(sp_start);
+        perl_assert_ptr(avarr);
+        SP += (av_cur-1); /* leave SP on top of last valid element, not 1 after */
+        PUTBACK;
+        /* Ideally Copy() will tailcall to libc or do a theoretical unrealistic
+           croak() which resumes normal PP control flow. So do all of Copy()'s
+           croak()s and checks earlier. Now the PUTBACK to global state can be
+           done safely before Copy/memcpy executes, and tailcail out of here. */
+        memcpy((char*)(sp_start),(const char*)(avarr), (av_cur) * sizeof(SV *));
     }
-    EXTEND(SP, AvFILLp(av)+1);
-    Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
-    XSRETURN(AvFILLp(av)+1);
 }
 
 /* Copy an existing cop->cop_warnings field.