From 594c45d643751f7afe1092bf6b2bec22a912f135 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Thu, 16 Nov 2023 17:26:26 +0000 Subject: [PATCH 1/6] make RC-stack-aware: unwrap pp_index() Remove the temporary wrapper from pp_index() --- pp.c | 46 ++++++++++++++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/pp.c b/pp.c index 74d2e0fa944e..b327905ed860 100644 --- a/pp.c +++ b/pp.c @@ -3789,9 +3789,11 @@ PP_wrapped(pp_vec, 3, 0) /* also used for: pp_rindex() */ -PP_wrapped(pp_index, MAXARG, 0) +PP(pp_index) { - dSP; dTARGET; + SV *targ = (PL_op->op_flags & OPf_STACKED) + ? PL_stack_sp[-1] + : PAD_SV(PL_op->op_targ); SV *big; SV *little; SV *temp = NULL; @@ -3804,12 +3806,24 @@ PP_wrapped(pp_index, MAXARG, 0) bool big_utf8; bool little_utf8; const bool is_index = PL_op->op_type == OP_INDEX; - const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0)); - if (threeargs) - offset = POPi; - little = POPs; - big = POPs; + assert(MAXARG == 2 || MAXARG == 3); + + bool threeargs = (MAXARG == 3); + if (MAXARG == 3 && !PL_stack_sp[0]) { + /* pp_coreargs pushes a NULL in order to flag that &CORE::index() + * was called with two args */ + PL_stack_sp--; + threeargs = FALSE; + } + + if (threeargs) { + offset = SvIV(*PL_stack_sp); + rpp_popfree_1(); + } + + little = PL_stack_sp[0]; + big = PL_stack_sp[-1]; big_p = SvPV_const(big, biglen); little_p = SvPV_const(little, llen); @@ -3896,20 +3910,20 @@ PP_wrapped(pp_index, MAXARG, 0) if (PL_op->op_private & OPpTRUEBOOL) { SV *result = ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG)) ? &PL_sv_yes : &PL_sv_no; - if (PL_op->op_private & OPpTARGET_MY) { + if (PL_op->op_private & OPpTARGET_MY) /* $lex = (index() == -1) */ - sv_setsv_mg(TARG, result); - PUSHs(TARG); - } - else { - PUSHs(result); - } + sv_setsv_mg(targ, result); + else + targ = result; } else - PUSHi(retval); - RETURN; + TARGi(retval, 1); + + rpp_replace_2_1(targ); + return NORMAL; } + PP_wrapped(pp_sprintf, 0, 1) { dSP; dMARK; dORIGMARK; dTARGET; From 591200f6f0f3257838efb8d5103b955e84db6ffd Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Sat, 25 Nov 2023 12:05:39 +0000 Subject: [PATCH 2/6] IO::getline(): use CALLRUNOPS This XS function calls Perl_pp_readline() directly. Instead, invoke the op via CALLRUNOPS(): the run loop (that will just run a single op) can handle the case of the caller having a non-reference-counted stack, but when the ops it calls are expecting a reference-counted stack. Perl_pp_readline() will (in a few commits' time) indeed be expecting a reference-counted stack. --- dist/IO/IO.xs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs index c553987afd73..725b5b935784 100644 --- a/dist/IO/IO.xs +++ b/dist/IO/IO.xs @@ -556,9 +556,7 @@ PPCODE: myop.op_flags = (ix ? OPf_WANT_SCALAR : OPf_WANT_LIST ) | OPf_STACKED; myop.op_ppaddr = PL_ppaddr[OP_READLINE]; myop.op_type = OP_READLINE; - /* I don't know if we need this, but it's correct as far as the control flow - goes. However, if we *do* need it, do we need to set anything else up? */ - myop.op_next = PL_op->op_next; + myop.op_next = NULL; /* return from the runops loop below after 1 op */ /* Sigh, because pp_readline calls pp_rv2gv, and *it* has this wonderful state check for PL_op->op_type == OP_READLINE */ PL_op = (OP *) &myop; @@ -569,9 +567,12 @@ PPCODE: PUSHs(sv_newmortal()); XPUSHs(io); PUTBACK; + /* call a new runops loop for just the one op rather than just calling + * pp_readline directly, as the former will handle the call coming + * from a ref-counted stack */ /* And effectively we get away with tail calling pp_readline, as it stacks exactly the return value(s) we need to return. */ - PL_ppaddr[OP_READLINE](aTHX); + CALLRUNOPS(aTHX); PL_op = was; /* And we don't want to reach the line PL_stack_sp = sp; From d25231bc219ffc858cb4291da9ca933e958dcf41 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Sat, 25 Nov 2023 23:00:22 +0000 Subject: [PATCH 3/6] IO::getline() handle OPf_STACKED better When calling Perl_pp_readline(), only set OPf_STACKED, and only create a dummy stacked target, when in scalar context. getline() had been sort of getting away with always setting it, but the next commit but one will make pp_readline() more strict about its flag handling (basically adding lots of asserts and only processing the target when OPf_STACKED is set). This change has been wrapped in a version #ifdef, as on older perls pp_readline() will unconditionally try to retrieve the targ from the pad if OPf_STACKED isn't set, and probably crash. Note that until the next commit but one, this commit will probably fail t/io_getline.t. --- dist/IO/IO.xs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs index 725b5b935784..362bdad9601f 100644 --- a/dist/IO/IO.xs +++ b/dist/IO/IO.xs @@ -553,7 +553,11 @@ PPCODE: if (!ix && GIMME_V != G_LIST) Perl_croak(aTHX_ "Can't call $io->getlines in a scalar context, use $io->getline"); Zero(&myop, 1, UNOP); +#if PERL_VERSION_GE(5,39,6) + myop.op_flags = (ix ? (OPf_WANT_SCALAR | OPf_STACKED) : OPf_WANT_LIST); +#else myop.op_flags = (ix ? OPf_WANT_SCALAR : OPf_WANT_LIST ) | OPf_STACKED; +#endif myop.op_ppaddr = PL_ppaddr[OP_READLINE]; myop.op_type = OP_READLINE; myop.op_next = NULL; /* return from the runops loop below after 1 op */ @@ -561,10 +565,12 @@ PPCODE: state check for PL_op->op_type == OP_READLINE */ PL_op = (OP *) &myop; io = ST(0); - /* Our target (which we need to provide, as we don't have a pad entry. - I think that this is only needed for G_SCALAR - maybe we can get away - with NULL for list context? */ - PUSHs(sv_newmortal()); + /* For scalar functions (getline/gets), provide a target on the stack, + * as we don't have a pad entry. */ +#if PERL_VERSION_GE(5,39,6) + if (ix) +#endif + PUSHs(sv_newmortal()); XPUSHs(io); PUTBACK; /* call a new runops loop for just the one op rather than just calling From 14c47929512aa30191dca1f037cc3584580023c8 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Thu, 16 Nov 2023 18:25:50 +0000 Subject: [PATCH 4/6] expand tryAMAGICunTARGETlist() macro This long macro is only used in two places (pp_readline and pp_glob). Expand the contents of this macro directly in those two functions. This will make it easier to individually unwrap (i.e. remove PP_wrapped()) those two functions. Shouldn't be any functional change. --- pp.h | 2 ++ pp_hot.c | 36 +++++++++++++++++++++++++++++++++++- pp_sys.c | 44 +++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 80 insertions(+), 2 deletions(-) diff --git a/pp.h b/pp.h index 8ac7e5aa0a43..cb84fc6d0e3d 100644 --- a/pp.h +++ b/pp.h @@ -681,6 +681,8 @@ Does not use C. See also C>, C> and C>. /* No longer used in core. Use AMG_CALLunary instead */ #define AMG_CALLun(sv,meth) AMG_CALLunary(sv, CAT2(meth,_amg)) +/* No longer used in core. Was expanded directly into its only two users, + * pp_readline and pp_glob */ #define tryAMAGICunTARGETlist(meth, jump) \ STMT_START { \ dSP; \ diff --git a/pp_hot.c b/pp_hot.c index 0061f83e5282..52c16c5a5ac0 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1497,7 +1497,41 @@ PP_wrapped(pp_readline, ((PL_op->op_flags & OPf_STACKED) ? 2 : 1), 0) * CORE::readline() */ if (TOPs) { SvGETMAGIC(TOPs); - tryAMAGICunTARGETlist(iter_amg, 0); + + /* unrolled tryAMAGICunTARGETlist(iter_amg, 0) */ + SV *tmpsv; + SV *arg= *sp; + U8 gimme = GIMME_V; + if (UNLIKELY(SvAMAGIC(arg) && + (tmpsv = amagic_call(arg, &PL_sv_undef, iter_amg, + AMGf_want_list | AMGf_noright + |AMGf_unary)))) + { + SPAGAIN; + if (gimme == G_VOID) { + NOOP; + } + else if (gimme == G_LIST) { + SSize_t i; + SSize_t len; + assert(SvTYPE(tmpsv) == SVt_PVAV); + len = av_count((AV *)tmpsv); + (void)POPs; /* get rid of the arg */ + EXTEND(sp, len); + for (i = 0; i < len; ++i) + PUSHs(av_shift((AV *)tmpsv)); + } + else { /* AMGf_want_scalar */ + dATARGET; /* just use the arg's location */ + sv_setsv(TARG, tmpsv); + if (PL_op->op_flags & OPf_STACKED) + sp--; + SETTARG; + } + PUTBACK; + return NORMAL; + } + PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); } else PL_last_in_gv = PL_argvgv, PL_stack_sp--; diff --git a/pp_sys.c b/pp_sys.c index 636280ca5a2f..06e5b6ee77dd 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -351,7 +351,49 @@ PP_wrapped(pp_glob, 1 + !(PL_op->op_flags & OPf_SPECIAL), 0) * is called once and only once */ if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs)); - tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL)); + /* unrolled + tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL)); */ + SV *tmpsv; + SV *arg= *sp; + U8 gimme = GIMME_V; + if (UNLIKELY(SvAMAGIC(arg) && + (tmpsv = amagic_call(arg, &PL_sv_undef, iter_amg, + AMGf_want_list | AMGf_noright + |AMGf_unary)))) + { + SPAGAIN; + if (gimme == G_VOID) { + NOOP; + } + else if (gimme == G_LIST) { + SSize_t i; + SSize_t len; + assert(SvTYPE(tmpsv) == SVt_PVAV); + len = av_count((AV *)tmpsv); + (void)POPs; /* get rid of the arg */ + EXTEND(sp, len); + for (i = 0; i < len; ++i) + PUSHs(av_shift((AV *)tmpsv)); + } + else { /* AMGf_want_scalar */ + dATARGET; /* just use the arg's location */ + sv_setsv(TARG, tmpsv); + if (PL_op->op_flags & OPf_STACKED) + sp--; + SETTARG; + } + PUTBACK; + if (PL_op->op_flags & OPf_SPECIAL) { + OP *jump_o = NORMAL->op_next; + while (jump_o->op_type == OP_NULL) + jump_o = jump_o->op_next; + assert(jump_o->op_type == OP_ENTERSUB); + (void)POPMARK; + return jump_o->op_next; + } + return NORMAL; + } + if (PL_op->op_flags & OPf_SPECIAL) { /* call Perl-level glob function instead. Stack args are: From 651f4b6c76d59d6258fe672000c6ce9a23c993a1 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Thu, 23 Nov 2023 18:21:38 +0000 Subject: [PATCH 5/6] make RC-stack-aware: pp_readline(), pp_glob() etc Remove the temporary wrappers from: pp_readline() pp_rcatline() pp_glob() pp_rv2gv() and dependent functions. This started out as an attempt to unwrap the simple pp_rv2gv() function. But pp_readline() calls pp_rv2gv() too, so that had to be unwrapped too. Then the bulk of pp_readline()'s implementation is done by do_readline(), so that had to be updated too. But pp_rcatline() and pp_glob() also call out to do_readline(), so they had to be fixed too. And pp_glob() outsources most of its work to the XS module File::Glob, so calling that had to be wrapped to handle a non-refcounted stack in the XS code. Then it turns out that code in IO.xs calls pp_readline() directly and needed tweaking. So now its a large commit that updates nearly everything in one big go. While fixing up everything, I took the opportunity to add many code comments and asserts to better document what these various functions do, and what args they expect on the stack under what flag conditions. The op_flag processing is now more strict, so potentially other code which directly fakes up an op with sloppy flag settings and calls one of these pp functions directly might now trigger an assert failure. (See the fix-up to IO.xs a couple of commits ago for an example.) --- gv.c | 7 ++ pp.c | 10 +- pp_hot.c | 306 ++++++++++++++++++++++++++++++++++++++++++++----------- pp_sys.c | 124 ++++++++++++++++++---- 4 files changed, 366 insertions(+), 81 deletions(-) diff --git a/gv.c b/gv.c index 93fc37da63a5..de1d554b6886 100644 --- a/gv.c +++ b/gv.c @@ -4195,6 +4195,13 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) res = newSV_type_mortal(SVt_PVAV); av_extend((AV *)res, nret); while (nret--) + /* Naughtily, we don't increment the ref counts + * of the items we push onto the temporary array. + * So we rely on the caller knowing not to decrement them, + * and to empty the array before there's any chance of + * it being freed. (Probably should either turn off + * AvREAL or actually increment.) + */ av_store((AV *)res, nret, POPs); break; } diff --git a/pp.c b/pp.c index b327905ed860..44bca5b117e5 100644 --- a/pp.c +++ b/pp.c @@ -186,9 +186,10 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, return sv; } -PP_wrapped(pp_rv2gv, 1, 0) + +PP(pp_rv2gv) { - dSP; dTOPss; + SV *sv = *PL_stack_sp; sv = S_rv2gv(aTHX_ sv, PL_op->op_private & OPpDEREF, @@ -198,10 +199,11 @@ PP_wrapped(pp_rv2gv, 1, 0) ); if (PL_op->op_private & OPpLVAL_INTRO) save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL)); - SETs(sv); - RETURN; + rpp_replace_1_1(sv); + return NORMAL; } + /* Helper function for pp_rv2sv and pp_rv2av/hv. * * Return a GV based on the value of sv, using symbolic references etc. diff --git a/pp_hot.c b/pp_hot.c index 52c16c5a5ac0..be0741bba285 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1490,24 +1490,58 @@ PP(pp_padsv) } } -PP_wrapped(pp_readline, ((PL_op->op_flags & OPf_STACKED) ? 2 : 1), 0) + +/* Implement readline(), and also and <> in the cases where X is + * seen by the parser as file-handle-ish rather than glob-ish. + * + * It expects at least one arg: the typeglob or scalar filehandle to read + * from. An empty <> isn't handled specially by this op; instead the parser + * will have planted a preceding gv(*ARGV) op. + * + * Scalar assignment is optimised away by making the assignment target be + * passed as a second argument, with OPf_STACKED set. For example, + * + * $x[$i] = readline($fh); + * + * is implemented as if written as + * + * readline($x[$i], $fh); + * + * (that is, if the perl-level readline function took two args, which it + * doesn't). The 'while (<>) {...}' construct is handled specially by the + * parser, but not specially by this op. The parser treats the condition + * as + * + * defined($_ = <>) + * + * which is then optimised into the equivalent of + * + * defined(readline($_, *ARGV)) + * + * When called as a real function, e.g. (\&CORE::readline)->(*STDIN), + * pp_coreargs() will have pushed a NULL if no argument was supplied. + * + * The parser decides whether '' in the perl src code causes an + * OP_GLOB or an OPREADLINE op to be planted. + */ + +PP(pp_readline) { - dSP; + SV *arg = *PL_stack_sp; + /* pp_coreargs pushes a NULL to indicate no args passed to * CORE::readline() */ - if (TOPs) { - SvGETMAGIC(TOPs); + if (arg) { + SvGETMAGIC(arg); /* unrolled tryAMAGICunTARGETlist(iter_amg, 0) */ SV *tmpsv; - SV *arg= *sp; U8 gimme = GIMME_V; if (UNLIKELY(SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, iter_amg, AMGf_want_list | AMGf_noright |AMGf_unary)))) { - SPAGAIN; if (gimme == G_VOID) { NOOP; } @@ -1516,37 +1550,63 @@ PP_wrapped(pp_readline, ((PL_op->op_flags & OPf_STACKED) ? 2 : 1), 0) SSize_t len; assert(SvTYPE(tmpsv) == SVt_PVAV); len = av_count((AV *)tmpsv); - (void)POPs; /* get rid of the arg */ - EXTEND(sp, len); + assert(*PL_stack_sp == arg); + rpp_popfree_1(); /* pop the original filehhandle arg */ + /* no assignment target to pop */ + assert(!(PL_op->op_flags & OPf_STACKED)); + rpp_extend(len); for (i = 0; i < len; ++i) - PUSHs(av_shift((AV *)tmpsv)); + /* amagic_call() naughtily doesn't increment the ref counts + * of the items it pushes onto the temporary array. So we + * don't need to decrement them when shifting off. */ + rpp_push_1(av_shift((AV *)tmpsv)); } else { /* AMGf_want_scalar */ - dATARGET; /* just use the arg's location */ - sv_setsv(TARG, tmpsv); - if (PL_op->op_flags & OPf_STACKED) - sp--; - SETTARG; + /* OPf_STACKED: assignment optimised away and target + * on stack */ + SV *targ = (PL_op->op_flags & OPf_STACKED) + ? PL_stack_sp[-1] + : PAD_SV(PL_op->op_targ); + sv_setsv(targ, tmpsv); + SvSETMAGIC(targ); + if (PL_op->op_flags & OPf_STACKED) { + rpp_popfree_1(); + assert(*PL_stack_sp == targ); + } + else + rpp_replace_1_1(targ); } - PUTBACK; return NORMAL; } + /* end of unrolled tryAMAGICunTARGETlist */ - PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); + PL_last_in_gv = MUTABLE_GV(*PL_stack_sp); +#ifdef PERL_RC_STACK + /* PL_last_in_gv appears to be non-refcounted, so won't keep + * GV alive */ + if (SvREFCNT(PL_last_in_gv) < 2) + sv_2mortal((SV*)PL_last_in_gv); +#endif } - else PL_last_in_gv = PL_argvgv, PL_stack_sp--; + else + PL_last_in_gv = PL_argvgv; + + rpp_popfree_1(); + + /* is it *FOO, $fh, or 'FOO' ? */ if (!isGV_with_GP(PL_last_in_gv)) { if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv))) PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv)); else { - dSP; - XPUSHs(MUTABLE_SV(PL_last_in_gv)); - PUTBACK; + rpp_xpush_1(MUTABLE_SV(PL_last_in_gv)); Perl_pp_rv2gv(aTHX); - PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); - assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv)); + PL_last_in_gv = MUTABLE_GV(*PL_stack_sp); + rpp_popfree_1(); + assert( (SV*)PL_last_in_gv == &PL_sv_undef + || isGV_with_GP(PL_last_in_gv)); } } + return do_readline(); } @@ -3877,34 +3937,122 @@ PP(pp_match) } +/* Perl_do_readline(): implement <$fh>, readline($fh) and glob('*.h') + * + * This function is tail-called by pp_readline(), pp_rcatline() and + * pp_glob(), and it may check PL_op's op_type and op_flags as + * appropriate. + * + * For file reading: + * It reads the line(s) from PL_last_in_gv. + * It returns a list of lines, or in scalar context, reads one line into + * targ (or if OPf_STACKED, into the top SV on the stack), and + * returns that. (If OP_RCATLINE, concats rather than sets). + * + * So it normally expects zero args, or one arg when the OPf_STACKED + * optimisation is present. + * + * For file globbing: + * Note that we don't normally reach here: we only get here if perl is + * built with PERL_EXTERNAL_GLOB, which is normally only when + * building miniperl. + * + * Expects one arg, which is the pattern string (e.g. '*.h'). + * The caller sets PL_last_in_gv to a plain GV that just has a new + * IO::File PVIO attached. + * + * Handles tied IO magic, but not overloading - that's the caller's + * responsibility. + * + * Handles the *ARGV filehandle specially, to do all the <> wizardry. + * + * In summary: on entry, the stack has zero or one items pushed, and + * looks like: + * + * - when OP_READLINE without OPf_STACKED + * target when OP_READLINE with OPf_STACKED, or when OP_RCATLINE + * '*.h' when OP_GLOB + */ + OP * Perl_do_readline(pTHX) { - dSP; dTARGETSTACKED; + + const I32 type = PL_op->op_type; + + /* only readline/rcatline can have the STACKED optimisation, + * and rcatline *always* has it */ + if (PL_op->op_flags & OPf_STACKED) { + assert(type != OP_GLOB); + assert(GIMME_V == G_SCALAR); + } + if (type == OP_RCATLINE) + assert(PL_op->op_flags & OPf_STACKED); + + const U8 gimme = GIMME_V; + SV *targ = (gimme == G_SCALAR) + ? (PL_op->op_flags & OPf_STACKED) + ? *PL_stack_sp + : PAD_SV(PL_op->op_targ) + : NULL; SV *sv; STRLEN tmplen = 0; STRLEN offset; PerlIO *fp; IO * const io = GvIO(PL_last_in_gv); - const I32 type = PL_op->op_type; - const U8 gimme = GIMME_V; + + /* process tied file handle if present */ if (io) { const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0); + /* not possible for the faked-up IO passed by an OP_GLOB to be + * tied */ + assert(type != OP_GLOB); + /* OPf_STACKED only applies when in scalar context */ + assert(!(gimme != G_SCALAR && (PL_op->op_flags & OPf_STACKED))); + + /* tied_method() frees everything currently above the passed + * mark, and returns any values at mark[1] onwards */ + Perl_tied_method(aTHX_ SV_CONST(READLINE), + /* mark => */ PL_stack_sp, + MUTABLE_SV(io), mg, gimme, 0); + if (gimme == G_SCALAR) { - SPAGAIN; - SvSetSV_nosteal(TARG, TOPs); - SETTARG; + SvSetSV_nosteal(targ, *PL_stack_sp); + SvSETMAGIC(targ); + if (PL_op->op_flags & OPf_STACKED) { + /* free the tied method call's return value */ + rpp_popfree_1(); + assert(*PL_stack_sp == targ); + } + else + rpp_replace_1_1(targ); } + else + /* no targ to pop off the stack - any returned values + * are in the right place in the stack */ + assert(!(PL_op->op_flags & OPf_STACKED)); + return NORMAL; } } + fp = NULL; + + /* handle possible *ARGV, and check for read on write-only FH */ + if (io) { fp = IoIFP(io); - if (!fp) { + if (fp) { + /* not possible for the faked-up IO passed by an OP_GLOB to + * have a file handle */ + assert(type != OP_GLOB); + + if (IoTYPE(io) == IoTYPE_WRONLY) + report_wrongway_fh(PL_last_in_gv, '>'); + } + else { if (IoFLAGS(io) & IOf_ARGV) { if (IoFLAGS(io) & IOf_START) { IoLINES(io) = 0; @@ -3923,15 +4071,15 @@ Perl_do_readline(pTHX) (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ } } - else if (type == OP_GLOB) - fp = Perl_start_glob(aTHX_ POPs, io); - } - else if (type == OP_GLOB) - SP--; - else if (IoTYPE(io) == IoTYPE_WRONLY) { - report_wrongway_fh(PL_last_in_gv, '>'); + else if (type == OP_GLOB) { + fp = Perl_start_glob(aTHX_ *PL_stack_sp, io); + rpp_popfree_1(); + } } } + + /* handle bad file handle */ + if (!fp) { if ((!io || !(IoFLAGS(io) & IOf_START)) && ckWARN(WARN_CLOSED) @@ -3939,20 +4087,26 @@ Perl_do_readline(pTHX) { report_evil_fh(PL_last_in_gv); } + if (gimme == G_SCALAR) { - /* undef TARG, and push that undefined value */ - if (type != OP_RCATLINE) { - sv_set_undef(TARG); - } - PUSHTARG; + /* undef targ, and return that undefined value */ + if (type != OP_RCATLINE) + sv_set_undef(targ); + if (!(PL_op->op_flags & OPf_STACKED)) + rpp_push_1(targ); } - RETURN; + return NORMAL; } + have_fp: + + /* prepare targ to have a string assigned to it */ + if (gimme == G_SCALAR) { - sv = TARG; + sv = targ; if (type == OP_RCATLINE && SvGMAGICAL(sv)) mg_get(sv); + if (SvROK(sv)) { if (type == OP_RCATLINE) SvPV_force_nomg_nolen(sv); @@ -3962,6 +4116,7 @@ Perl_do_readline(pTHX) else if (isGV_with_GP(sv)) { SvPV_force_nomg_nolen(sv); } + SvUPGRADE(sv, SVt_PV); tmplen = SvLEN(sv); /* remember if already alloced */ if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) { @@ -3970,6 +4125,7 @@ Perl_do_readline(pTHX) */ Sv_Grow(sv, 80); } + offset = 0; if (type == OP_RCATLINE && SvOK(sv)) { if (!SvPOK(sv)) { @@ -3979,6 +4135,7 @@ Perl_do_readline(pTHX) } } else { + /* XXX on RC builds, push on stack rather than mortalize ? */ sv = sv_2mortal(newSV(80)); offset = 0; } @@ -3995,8 +4152,9 @@ Perl_do_readline(pTHX) (gimme != G_SCALAR || SvCUR(sv) \ || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) + /* create one or more lines, or (if OP_GLOB), pathnames */ + for (;;) { - PUTBACK; if (!sv_gets(sv, fp, offset) && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv) @@ -4022,27 +4180,44 @@ Perl_do_readline(pTHX) (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); } } + if (gimme == G_SCALAR) { if (type != OP_RCATLINE) { - SV_CHECK_THINKFIRST_COW_DROP(TARG); - SvOK_off(TARG); + SV_CHECK_THINKFIRST_COW_DROP(targ); + SvOK_off(targ); } - SPAGAIN; - PUSHTARG; + /* targ not already there? */ + if (!(PL_op->op_flags & OPf_STACKED)) + rpp_push_1(targ); } + else if (PL_op->op_flags & OPf_STACKED) + rpp_popfree_1(); + MAYBE_TAINT_LINE(io, sv); - RETURN; + return NORMAL; } + MAYBE_TAINT_LINE(io, sv); IoLINES(io)++; IoFLAGS(io) |= IOf_NOLINE; SvSETMAGIC(sv); - SPAGAIN; - XPUSHs(sv); + rpp_extend(1); + if (PL_op->op_flags & OPf_STACKED) { + /* push sv while keeping targ above it, so targ doesn't get + * freed */ + assert(*PL_stack_sp == targ); + PL_stack_sp[1] = targ; + *PL_stack_sp++ = NULL; + rpp_replace_at(PL_stack_sp - 1, sv); + } + else + rpp_push_1(sv); + if (type == OP_GLOB) { const char *t1; Stat_t statbuf; + /* chomp(sv) */ if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { char * const tmps = SvEND(sv) - 1; if (*tmps == *SvPVX_const(PL_rs)) { @@ -4050,18 +4225,26 @@ Perl_do_readline(pTHX) SvCUR_set(sv, SvCUR(sv) - 1); } } - for (t1 = SvPVX_const(sv); *t1; t1++) + + /* find longest substring of sv up to first metachar */ + for (t1 = SvPVX_const(sv); *t1; t1++) { #ifdef __VMS if (memCHRs("*%?", *t1)) #else if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1)) #endif break; + } + if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) { - (void)POPs; /* Unmatched wildcard? Chuck it... */ + /* Unmatched wildcard? Chuck it... */ + /* no need to worry about targ still on top of stack */ + assert(!(PL_op->op_flags & OPf_STACKED)); + rpp_popfree_1(); continue; } } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ + /* check line if valid Unicode */ if (ckWARN(WARN_UTF8)) { const U8 * const s = (const U8*)SvPVX_const(sv) + offset; const STRLEN len = SvCUR(sv) - offset; @@ -4074,23 +4257,32 @@ Perl_do_readline(pTHX) f < (U8*)SvEND(sv) ? *f : 0); } } + if (gimme == G_LIST) { if (SvLEN(sv) - SvCUR(sv) > 20) { SvPV_shrink_to_cur(sv); } + /* XXX on RC builds, push on stack rather than mortalize ? */ sv = sv_2mortal(newSV(80)); continue; } - else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { + + if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { /* try to reclaim a bit of scalar space (only on 1st alloc) */ const STRLEN new_len = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */ SvPV_renew(sv, new_len); } - RETURN; - } + + + if (PL_op->op_flags & OPf_STACKED) + rpp_popfree_1(); /* finally remove targ */ + /* return sv, which was recently pushed onto the stack */ + return NORMAL; + } /* for (;;) */ } + PP(pp_helem) { HE* he; diff --git a/pp_sys.c b/pp_sys.c index 06e5b6ee77dd..1deb3813fe68 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -339,29 +339,62 @@ PP_wrapped(pp_backtick, 1, 0) RETURN; } -PP_wrapped(pp_glob, 1 + !(PL_op->op_flags & OPf_SPECIAL), 0) + +/* Implement glob('*.h'), and also in the cases where the X is seen by + * the parser as glob-ish rather than file-handle-ish. + * + * The first arg is the wildcard. + * + * The second arg is a gv which (for some reason) is just an empty + * placeholder to temporarily assign to PL_last_in_gv. It's a GV unique to + * this op with only a plain PVIO attached, which is in stash IO::File. + * Presumably this is used because we tail-call do_readline(), which + * expects PL_last_in_gv to be set. + * + * With OPf_SPECIAL, the second arg isn't present, but a stack MARK is, + * and the glob is done by following on in op_next to a perl-level + * function call. + * + * Normally, the actual glob work is done within a tail-call to + * do_readline(). + * + * The parser decides whether '' in the perl src code causes an + * OP_GLOB or an OPREADLINE op to be planted. + */ + +PP(pp_glob) { OP *result; - dSP; - GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs; + GV *gv; + if (UNLIKELY(PL_op->op_flags & OPf_SPECIAL)) { + /* no GV on stack */ + gv = NULL; + } + else { + gv = (GV*)*PL_stack_sp; + /* Normally things can't just be popped off the stack without risk + * of premature freeing, but in this case the GV is always + * referenced by a preceding OP_GV. */ + assert(!rpp_is_lone((SV*)gv)); + rpp_popfree_1(); + } - PUTBACK; /* make a copy of the pattern if it is gmagical, to ensure that magic * is called once and only once */ - if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs)); + SV *arg = *PL_stack_sp; + if (SvGMAGICAL(arg)) + rpp_replace_at_norc(PL_stack_sp, ((arg = newSVsv(arg)) )); /* unrolled tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL)); */ SV *tmpsv; - SV *arg= *sp; U8 gimme = GIMME_V; if (UNLIKELY(SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, iter_amg, AMGf_want_list | AMGf_noright |AMGf_unary)))) { - SPAGAIN; if (gimme == G_VOID) { NOOP; } @@ -370,40 +403,85 @@ PP_wrapped(pp_glob, 1 + !(PL_op->op_flags & OPf_SPECIAL), 0) SSize_t len; assert(SvTYPE(tmpsv) == SVt_PVAV); len = av_count((AV *)tmpsv); - (void)POPs; /* get rid of the arg */ - EXTEND(sp, len); + assert(*PL_stack_sp == arg); + rpp_popfree_1(); /* pop the original wildcard arg */ + rpp_extend(len); for (i = 0; i < len; ++i) - PUSHs(av_shift((AV *)tmpsv)); + /* amagic_call() naughtily doesn't increment the ref counts + * of the items it pushes onto the temporary array. So we + * don't need to decrement them when shifting off. */ + rpp_push_1(av_shift((AV *)tmpsv)); } else { /* AMGf_want_scalar */ - dATARGET; /* just use the arg's location */ - sv_setsv(TARG, tmpsv); - if (PL_op->op_flags & OPf_STACKED) - sp--; - SETTARG; + SV *targ = PAD_SV(PL_op->op_targ); + sv_setsv(targ, tmpsv); + SvSETMAGIC(targ); + /* replace the original wildcard arg with result */ + assert(*PL_stack_sp == arg); + rpp_replace_1_1(targ); } - PUTBACK; + if (PL_op->op_flags & OPf_SPECIAL) { - OP *jump_o = NORMAL->op_next; + /* skip the following gv(CORE::GLOBAL::glob), entersub ops */ + OP *jump_o = PL_op->op_next->op_next; while (jump_o->op_type == OP_NULL) jump_o = jump_o->op_next; assert(jump_o->op_type == OP_ENTERSUB); (void)POPMARK; return jump_o->op_next; } + return NORMAL; } + /* end of unrolled tryAMAGICunTARGETlist */ if (PL_op->op_flags & OPf_SPECIAL) { - /* call Perl-level glob function instead. Stack args are: - * MARK, wildcard + /* call Perl-level glob function instead. E.g. + * use File::DosGlob 'glob'; @files = glob('*.h'); + * Stack args are: [MARK] wildcard * and following OPs should be: gv(CORE::GLOBAL::glob), entersub * */ return NORMAL; } + if (PL_globhook) { +#ifdef PERL_RC_STACK + /* Likely calling csh_glob_iter() in File::Glob, which doesn't + * understand PERL_RC_STACK yet. If it was an XS function we could + * use rpp_invoke_xs(); but as it's just a "raw" static function, + * wrap it ourselves. There's always one arg, and it will return + * one value in void/scalar context (possibly PL_sv_undef), or 0+ + * values in list cxt. */ + + assert(AvREAL(PL_curstack)); + assert(!PL_curstackinfo->si_stack_nonrc_base); + + rpp_extend(1); + PL_stack_sp[1] = PL_stack_sp[0]; + PL_stack_sp++; + PL_curstackinfo->si_stack_nonrc_base = PL_stack_sp - PL_stack_base; + PL_globhook(aTHX); + + I32 nret = (I32)(PL_stack_sp - PL_stack_base) + - PL_curstackinfo->si_stack_nonrc_base + 1; + assert(nret >= 0); + + /* bump any returned values */ + for (I32 i = 0; i< nret; i++) + SvREFCNT_inc(PL_stack_sp[-i]); + PL_curstackinfo->si_stack_nonrc_base = 0; + + /* free the original arg and shift the returned values down */ + SV *arg = PL_stack_sp[-nret]; + if (nret) + Move(PL_stack_sp - nret + 1, PL_stack_sp - nret, nret, SV*); + PL_stack_sp--; + SvREFCNT_dec_NN(arg); +#else + PL_globhook(aTHX); +#endif return NORMAL; } @@ -440,12 +518,18 @@ PP_wrapped(pp_glob, 1 + !(PL_op->op_flags & OPf_SPECIAL), 0) return result; } -PP_wrapped(pp_rcatline, 1, 0) + +/* $x .= + * Where $x is on the stack and FOO is the GV attached to the op. + */ + +PP(pp_rcatline) { PL_last_in_gv = cGVOP_gv; return do_readline(); } + PP_wrapped(pp_warn, 0, 1) { dSP; dMARK; From 99e4f4b1c4bc11fc21660d3dcd3c6eb584361c54 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Tue, 5 Dec 2023 12:13:21 +0000 Subject: [PATCH 6/6] remove unused tryAMAGICunTARGETlist macro This macro was originally only used in two places in core (pp_readline and pp_glob), and nowhere on CPAN. The last few commits inlined those only two usages, then modified the functions using that code to be PERL_RC_STACK-aware. Since the macro is now unused, and is the old obsolete non-PERL_RC_STACK code, this commit just deletes it. --- pp.h | 47 ----------------------------------------------- 1 file changed, 47 deletions(-) diff --git a/pp.h b/pp.h index cb84fc6d0e3d..866c01e1e3e2 100644 --- a/pp.h +++ b/pp.h @@ -681,53 +681,6 @@ Does not use C. See also C>, C> and C>. /* No longer used in core. Use AMG_CALLunary instead */ #define AMG_CALLun(sv,meth) AMG_CALLunary(sv, CAT2(meth,_amg)) -/* No longer used in core. Was expanded directly into its only two users, - * pp_readline and pp_glob */ -#define tryAMAGICunTARGETlist(meth, jump) \ - STMT_START { \ - dSP; \ - SV *tmpsv; \ - SV *arg= *sp; \ - U8 gimme = GIMME_V; \ - if (UNLIKELY(SvAMAGIC(arg) && \ - (tmpsv = amagic_call(arg, &PL_sv_undef, meth, \ - AMGf_want_list | AMGf_noright \ - |AMGf_unary)))) \ - { \ - SPAGAIN; \ - if (gimme == G_VOID) { \ - NOOP; \ - } \ - else if (gimme == G_LIST) { \ - SSize_t i; \ - SSize_t len; \ - assert(SvTYPE(tmpsv) == SVt_PVAV); \ - len = av_count((AV *)tmpsv); \ - (void)POPs; /* get rid of the arg */ \ - EXTEND(sp, len); \ - for (i = 0; i < len; ++i) \ - PUSHs(av_shift((AV *)tmpsv)); \ - } \ - else { /* AMGf_want_scalar */ \ - dATARGET; /* just use the arg's location */ \ - sv_setsv(TARG, tmpsv); \ - if (PL_op->op_flags & OPf_STACKED) \ - sp--; \ - SETTARG; \ - } \ - PUTBACK; \ - if (jump) { \ - OP *jump_o = NORMAL->op_next; \ - while (jump_o->op_type == OP_NULL) \ - jump_o = jump_o->op_next; \ - assert(jump_o->op_type == OP_ENTERSUB); \ - (void)POPMARK; \ - return jump_o->op_next; \ - } \ - return NORMAL; \ - } \ - } STMT_END - /* This is no longer used anywhere in the core. You might wish to consider calling amagic_deref_call() directly, as it has a cleaner interface. */ #define tryAMAGICunDEREF(meth) \