NV nl = SvNVX(svl);
NV nr = SvNVX(svr);
- il = (IV)nl;
- ir = (IV)nr;
- if (nl == (NV)il && nr == (NV)ir)
+ if (
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
+ && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
+#else
+ nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
+#endif
+ )
/* nothing was lost by converting to IVs */
goto do_iv;
SP--;
svr = *relem;
assert(svr);
- if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK || copy_all)) {
+ if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
#ifdef DEBUGGING
if (fake) {
/* at least 2 LH and RH elements, or commonality isn't an issue */
if (firstlelem < lastlelem && firstrelem < lastrelem) {
+ for (relem = firstrelem+1; relem <= lastrelem; relem++) {
+ if (SvGMAGICAL(*relem))
+ goto do_scan;
+ }
for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
if (*lelem && SvSMAGICAL(*lelem))
goto do_scan;
/* a stripped-down version of Perl_softref2xv() for use by
* pp_multideref(), which doesn't use PL_op->op_flags */
-GV *
+STATIC GV *
S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
const svtype type)
{
if (gimme == G_SCALAR) {
MARK = newsp + 1;
if (LIKELY(MARK <= SP)) {
- if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
+ /* if we are recursing, then free the current tmps.
+ * Normally we don't bother and rely on the caller to do this,
+ * because early tmp freeing tends to free the args we're
+ * returning.
+ * Doing it for recursion ensures the things like the
+ * fibonacci benchmark don't fill up the tmps stack because
+ * it never reaches an outer nextstate */
+ if (cx->blk_sub.olddepth) {
if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
&& !SvMAGICAL(TOPs)) {
*MARK = SvREFCNT_inc(TOPs);
return cx->blk_sub.retop;
}
+
+/* clear (if possible) or abandon the current @_. If 'abandon' is true,
+ * forces an abandon */
+
+void
+Perl_clear_defarray(pTHX_ AV* av, bool abandon)
+{
+ const SSize_t fill = AvFILLp(av);
+
+ PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
+
+ if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av)))
+ av_clear(av);
+ else {
+ SvREFCNT_dec_NN(av);
+ av = newAV();
+ PAD_SVl(0) = MUTABLE_SV(av);
+ av_extend(av, fill);
+ }
+ AvREIFY_only(av);
+}
+
+
PP(pp_entersub)
{
dSP; dPOPss;
}
if (!cv) {
ENTER;
- SAVETMPS;
goto try_autoload;
}
break;
ENTER;
- retry:
- if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
- DIE(aTHX_ "Closure prototype called");
- if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
+ /* these two fields are in a union. If they ever become separate,
+ * we have to test for both of them being null below */
+ assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
+ while (UNLIKELY(!CvROOT(cv))) {
GV* autogv;
SV* sub_name;
/* should call AUTOLOAD now? */
else {
try_autoload:
- if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
- GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
- {
- cv = GvCV(autogv);
- }
- else {
- sorry:
- sub_name = sv_newmortal();
- gv_efullname3(sub_name, gv, NULL);
- DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
- }
- }
- if (!cv)
- goto sorry;
- goto retry;
+ autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
+ GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
+ cv = autogv ? GvCV(autogv) : NULL;
+ }
+ if (!cv) {
+ sub_name = sv_newmortal();
+ gv_efullname3(sub_name, gv, NULL);
+ DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
+ }
}
+ if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
+ DIE(aTHX_ "Closure prototype called");
+
if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
&& !CvNODEBUG(cv)))
{
PADLIST * const padlist = CvPADLIST(cv);
I32 depth;
+ /* keep PADTMP args alive throughout the call (we need to do this
+ * because @_ isn't refcounted). Note that we create the mortals
+ * in the caller's tmps frame, so they won't be freed until after
+ * we return from the sub.
+ */
+ {
+ SV **svp = MARK;
+ while (svp < SP) {
+ SV *sv = *++svp;
+ if (!sv)
+ continue;
+ if (SvPADTMP(sv))
+ *svp = sv = sv_mortalcopy(sv);
+ SvTEMP_off(sv);
+ }
+ }
+
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
+
cx->blk_sub.retop = PL_op->op_next;
if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
PERL_STACK_OVERFLOW_CHECK();
pad_push(padlist, depth);
}
- SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(padlist, depth);
if (LIKELY(hasargs)) {
AV *const av = MUTABLE_AV(PAD_SVl(0));
SSize_t items;
AV **defavp;
- if (UNLIKELY(AvREAL(av))) {
- /* @_ is normally not REAL--this should only ever
- * happen when DB::sub() calls things that modify @_ */
- av_clear(av);
- AvREAL_off(av);
- AvREIFY_on(av);
- }
defavp = &GvAV(PL_defgv);
cx->blk_sub.savearray = *defavp;
*defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
- CX_CURPAD_SAVE(cx->blk_sub);
- cx->blk_sub.argarray = av;
- items = SP - MARK;
+ /* it's the responsibility of whoever leaves a sub to ensure
+ * that a clean, empty AV is left in pad[0]. This is normally
+ * done by POPSUB() */
+ assert(!AvREAL(av) && AvFILLp(av) == -1);
+
+ items = SP - MARK;
if (UNLIKELY(items - 1 > AvMAX(av))) {
SV **ary = AvALLOC(av);
AvMAX(av) = items - 1;
Copy(MARK+1,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
-
- MARK = AvARRAY(av);
- while (items--) {
- if (*MARK)
- {
- if (SvPADTMP(*MARK)) {
- *MARK = sv_mortalcopy(*MARK);
- }
- SvTEMP_off(*MARK);
- }
- MARK++;
- }
}
- SAVETMPS;
if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
!CvLVALUE(cv)))
DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf,
https://perl5.git.perl.org / perl5.git / blobdiff