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

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.