diff --git a/XSUB.h b/XSUB.h index 9b7e98f64c56..954090ba2faa 100644 --- a/XSUB.h +++ b/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. Similar to the optree's + GETTARGET, but "specialized" for XSUBs written by core or written by CPAN. + The benefit of C over C is that C will return + C if a targ C isn't currently available and lets the user decide + how to go forward. Meanwhile C will always internally call + C if a targ C isn't available at that moment. + Do not evaluate this macro multiple times. Save the result of this macro to + a C var. + + Just like C, the C returned by C may have stale + prior contents in it. */ +/* + You must test the returned value for C 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. + 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. + + Assume C can return while at the same time C + returns non-NULL. Also assume C + can happen and therefore you very likely will need to allocate a new C + and mortalize it. It is discouraged and probably a bug, for an XSUB to + bump the C on C and save the C for later use. + Do not make assumptions about C's C, or what is the outer + container that really the C. Something else inside the interpreter + which is unspecified, owns C, and unspecified caller, probably + wants you to write into this C as an lval, vs you doing a less + efficient C/C, and later on the + unspecified caller has to call , and let the mortal stack dispose + of your short lived . + + 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 concept for both input and/or output + in various places between parts of itself and might be using C as + lvalue scratch pad in a loop. + + Remember that the C from C or C, might be C + and have stale prior contents that you need to wipe or free. C + functions will always do this for you. There is no guarentee the + from C or C will be set to C when you get it. + If you need to return C, you have 2 choices. Don't fetch and + don't use C, 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, or will it write + C 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 or + C. C is faster than the caller later on + doing a C. C has a quick bailout shortcut in it + if src and dest Cs are the same addr. + + There is also no guarentee about what its C is. + Always assume it is of type , and it has no SV body until you + you test its type and possibly call C or /C + on it. There is no guarentee C is non-NULL or C contains + a valid address or points to initialized memory. There is no guarentee + C is at minimum C and reading C 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) diff --git a/op.c b/op.c index 69ff030e88eb..44ef0fefdf96 100644 --- a/op.c +++ b/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.