Front page | perl.perl5.porters |
Postings from August 2013
Re: [perl #78194] Referencing a PADTMP twice produces two copies
Thread Previous
|
Thread Next
From:
Brian Fraser
Date:
August 12, 2013 19:24
Subject:
Re: [perl #78194] Referencing a PADTMP twice produces two copies
Message ID:
CA+nL+nYhb8JLqVy_mpD_eYcTEix5cKuVkYM02kx1MQR28EDoPg@mail.gmail.com
On Mon, Aug 12, 2013 at 6:00 AM, Father Chrysostomos via RT <
perlbug-comment@perl.org> wrote:
> On Sat Jul 27 11:27:57 2013, sprout wrote:
> > I did not fix this bug for calls to XSUBs, because it will make
> > Devel::Peek less useful. Calling Dump("$x") and being able to see what
> > pp_stringify is return[ing] is a useful feature.
> >
> > (Here I’m referring to the original bug reported, not the newRV issue.
> > Calling foo("$x") allowed the foo sub to see a TARG in $_[0], such that
> > print \$_[0], \$_[0] would show two different addresses.)
> >
> > Currently foo("$x") will make a COW copy of the TARG if it is a Perl
> > sub, but pass the TARG itself if it is an XSUB. So for XS code to call
> > newRV on that is wrong (or what newRV does is wrong).
> >
> > I think the real solution here is to apply the fix to XSUBs (copy TARG
> > arguments) but modify Devel::Peek to inline itself, so that it remains
> > exempt.
> >
> > That way the only XS code having access to TARGs will be that which
> > rummages through pads. For most XS code this will just dwim.
> >
> > In fact, having Devel::Peek inline itself would be useful for seeing the
> > return value of substr and vec in rvalue context, something currently
> > not possible.
>
> Attached is a patch to get Devel::Peek to inline itself. It also allows
> Dump %hash and Dump @array.
>
> It breaks compatibility in that ‘@args = ($thing, 5); Dump @args’ no
> longer works; scalar context is applied to both arguments now, and the
> number of arguments is checked at compile time, rather than run time.
>
> I still think it is worth it.
>
> The patch can also be found on the sprout/peek branch.
>
This is unrelated to the thread, but I just wanted to say that looking over
your attached patch made me go "Oh, so THAT'S how you create a custom op!"
Thanks, Father C! This was educational.
About the patch itself, I have never written Dump(@foo) and not meant
Dump(\@foo), or Dump %hash and not meant Dump(\%hash), so the incompatible
change seems good to me.
>
> --
>
> Father Chrysostomos
>
>
> From b71bcee5cdd1e9dc06692914a330bb543cacc16b Mon Sep 17 00:00:00 2001
> From: Father Chrysostomos <sprout@cpan.org>
> Date: Sun, 11 Aug 2013 21:54:11 -0700
> Subject: [PATCH] Inline Devel::Peek::Dump; allow Dump %hash etc.
> MIME-Version: 1.0
> Content-Type: text/plain; charset=UTF-8
> Content-Transfer-Encoding: 8bit
>
> This commit makes Devel::Peek::Dump modify the op tree to allow it to
> dump arrays and hashes directly via Dump @array and Dump %hash. It
> also puts other operators in rvalue context, allowing the return value
> of rvalue substr for instance to be dumped, making Devel::Peek more
> useful as a debugging tool.
>
> Since a future commit (to fix the rest of #78194) is likely to make
> pp_entersub copy PADTMPs (operator return values) for XSUBs (it
> already happens for Perl subs as of b479c9f2a), to the detriment of
> Devel::Peek’s usefulness, I also made it inline Dump as a custom op.
>
> This does introduce a backward-incompatible change, in that both argu-
> ments to Dump are now in scalar context, and the number of arguments
> is checked at compile time instead of run time (still run time for
> &Dump(...)), but I think it is worth it.
>
> diff --git a/ext/Devel-Peek/Peek.xs b/ext/Devel-Peek/Peek.xs
> index 4c5f974..edcb02f 100644
> --- a/ext/Devel-Peek/Peek.xs
> +++ b/ext/Devel-Peek/Peek.xs
> @@ -323,6 +323,94 @@ mstats2hash(SV *sv, SV *rv, int level)
> (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \
> ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef)
>
> +static void
> +S_do_dump(pTHX_ SV *const sv, I32 lim)
> +{
> + dVAR;
> + SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0);
> + const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
> + SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0);
> + const U16 save_dumpindent = PL_dumpindent;
> + PL_dumpindent = 2;
> + do_sv_dump(0, Perl_debug_log, sv, 0, lim,
> + (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
> + PL_dumpindent = save_dumpindent;
> +}
> +
> +static OP *
> +S_pp_dump(pTHX)
> +{
> + dSP;
> + const I32 lim = PL_op->op_private == 2 ? (I32)POPi : 4;
> + dPOPss;
> + S_do_dump(aTHX_ sv, lim);
> + RETPUSHUNDEF;
> +}
> +
> +static OP *
> +S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv)
> +{
> + OP *aop, *prev, *first, *second = NULL;
> + BINOP *newop;
> + size_t arg = 0;
> +
> + ck_entersub_args_proto(entersubop, namegv,
> + newSVpvn_flags("$;$", 3, SVs_TEMP));
> +
> + aop = cUNOPx(entersubop)->op_first;
> + if (!aop->op_sibling)
> + aop = cUNOPx(aop)->op_first;
> + prev = aop;
> + aop = aop->op_sibling;
> + while (PL_madskills && aop->op_type == OP_STUB) {
> + prev = aop;
> + aop = aop->op_sibling;
> + }
> + if (PL_madskills && aop->op_type == OP_NULL) {
> + first = ((UNOP*)aop)->op_first;
> + ((UNOP*)aop)->op_first = NULL;
> + prev = aop;
> + }
> + else {
> + first = aop;
> + prev->op_sibling = first->op_sibling;
> + }
> + if (first->op_type == OP_RV2AV ||
> + first->op_type == OP_PADAV ||
> + first->op_type == OP_RV2HV ||
> + first->op_type == OP_PADHV
> + )
> + first->op_flags |= OPf_REF;
> + else
> + first->op_flags &= ~OPf_MOD;
> + aop = aop->op_sibling;
> + while (PL_madskills && aop->op_type == OP_STUB) {
> + prev = aop;
> + aop = aop->op_sibling;
> + }
> + /* aop now points to the second arg if there is one, the cvop
> otherwise
> + */
> + if ((prev->op_sibling = aop->op_sibling)) {
> + second = aop;
> + second->op_sibling = NULL;
> + }
> + first->op_sibling = second;
> +
> + op_free(entersubop);
> +
> + NewOp(1234, newop, 1, BINOP);
> + newop->op_type = OP_CUSTOM;
> + newop->op_ppaddr = S_pp_dump;
> + newop->op_first = first;
> + newop->op_last = second;
> + newop->op_private= second ? 2 : 1;
> + newop->op_flags = OPf_KIDS|OPf_WANT_SCALAR;
> +
> + return (OP *)newop;
> +}
> +
> +static XOP my_xop;
> +
> MODULE = Devel::Peek PACKAGE = Devel::Peek
>
> void
> @@ -346,14 +434,18 @@ SV * sv
> I32 lim
> PPCODE:
> {
> - SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0);
> - const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
> - SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0);
> - const U16 save_dumpindent = PL_dumpindent;
> - PL_dumpindent = 2;
> - do_sv_dump(0, Perl_debug_log, sv, 0, lim,
> - (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
> - PL_dumpindent = save_dumpindent;
> + S_do_dump(aTHX_ sv, lim);
> +}
> +
> +BOOT:
> +{
> + CV * const cv = get_cvn_flags("Devel::Peek::Dump", 17, 0);
> + cv_set_call_checker(cv, S_ck_dump, (SV *)cv);
> +
> + XopENTRY_set(&my_xop, xop_name, "Dump");
> + XopENTRY_set(&my_xop, xop_desc, "Dump");
> + XopENTRY_set(&my_xop, xop_class, OA_BINOP);
> + Perl_custom_op_register(aTHX_ S_pp_dump, &my_xop);
> }
>
> void
> diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
> index 088f505..1f344df 100644
> --- a/ext/Devel-Peek/t/Peek.t
> +++ b/ext/Devel-Peek/t/Peek.t
> @@ -31,11 +31,24 @@ sub do_test {
> my $todo = $_[3];
> my $repeat_todo = $_[4];
> my $pattern = $_[2];
> + my $do_eval = $_[5];
> if (open(OUT,">peek$$")) {
> open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
> - Dump($_[1]);
> - print STDERR "*****\n";
> - Dump($_[1]); # second dump to compare with the first to make sure
> nothing changed.
> + if ($do_eval) {
> + my $sub = eval "sub { Dump $_[1] }";
> + $sub->();
> + print STDERR "*****\n";
> + # second dump to compare with the first to make sure nothing
> + # changed.
> + $sub->();
> + }
> + else {
> + Dump($_[1]);
> + print STDERR "*****\n";
> + # second dump to compare with the first to make sure nothing
> + # changed.
> + Dump($_[1]);
> + }
> open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
> close(OUT);
> if (open(IN, "peek$$")) {
> @@ -196,8 +209,8 @@ do_test('integer constant',
> do_test('undef',
> undef,
> 'SV = NULL\\(0x0\\) at $ADDR
> - REFCNT = 1
> - FLAGS = \\(\\)');
> + REFCNT = \d+
> + FLAGS = \\(READONLY\\)');
>
> do_test('reference to scalar',
> \$a,
> @@ -335,6 +348,8 @@ do_test('reference to named subroutine without
> prototype',
> \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
> \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
> \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
> + \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$do_eval"
> + \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$sub"
> \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" # $] <
> 5.009
> \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0 # $] >=
> 5.009
> \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
> @@ -968,6 +983,59 @@ do_test('large hash',
> Elt .*
> ');
>
> +# Dump with arrays, hashes, and operator return values
> +@array = 1..3;
> +do_test('Dump @array', '@array', <<'ARRAY', '', '', 1);
> +SV = PVAV\($ADDR\) at $ADDR
> + REFCNT = 1
> + FLAGS = \(\)
> + ARRAY = $ADDR
> + FILL = 2
> + MAX = 3
> + ARYLEN = 0x0
> + FLAGS = \(REAL\)
> + Elt No. 0
> + SV = IV\($ADDR\) at $ADDR
> + REFCNT = 1
> + FLAGS = \(IOK,pIOK\)
> + IV = 1
> + Elt No. 1
> + SV = IV\($ADDR\) at $ADDR
> + REFCNT = 1
> + FLAGS = \(IOK,pIOK\)
> + IV = 2
> + Elt No. 2
> + SV = IV\($ADDR\) at $ADDR
> + REFCNT = 1
> + FLAGS = \(IOK,pIOK\)
> + IV = 3
> +ARRAY
> +%hash = 1..2;
> +do_test('Dump %hash', '%hash', <<'HASH', '', '', 1);
> +SV = PVHV\($ADDR\) at $ADDR
> + REFCNT = 1
> + FLAGS = \(SHAREKEYS\)
> + ARRAY = $ADDR \(0:7, 1:1\)
> + hash quality = 100.0%
> + KEYS = 1
> + FILL = 1
> + MAX = 7
> + Elt "1" HASH = $ADDR
> + SV = IV\($ADDR\) at $ADDR
> + REFCNT = 1
> + FLAGS = \(IOK,pIOK\)
> + IV = 2
> +HASH
> +$_ = "hello";
> +do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', '', 1);
> +SV = PV\($ADDR\) at $ADDR
> + REFCNT = 1
> + FLAGS = \(PADTMP,POK,pPOK\)
> + PV = $ADDR "el"\\0
> + CUR = 2
> + LEN = 20
> +SUBSTR
> +
> SKIP: {
> skip "Not built with usemymalloc", 2
> unless $Config{usemymalloc} eq 'y';
>
>
Thread Previous
|
Thread Next