Segmentation fault while debugging programs using bignum in 5.18.2 #14013
Comments
From chr.stahlhut@gmail.comHi! Trying to debug the attached program via 'perl -d ./debug-me.pl' produces a segmentation fault for me. This seems to be related to the exact position of the breakpoint ('$DB::single=2') set in the code. Summary of my perl5 (revision 5 version 18 subversion 2) configuration: Characteristics of this binary (from libperl): |
From chr.stahlhut@gmail.comOn Wed Jul 30 14:51:25 2014, chr.stahlhut@gmail.com wrote:
To be more precise, this happens: christian@azmodan ~ $ perl -d ./debug-me.pl Loading DB routines from perl5db.pl version 1.39_10 Enter h or 'h h' for help, or 'man perldebug' for more help. main::(./debug-me.pl:4): $DB::single=2; |
From [Unknown Contact. See original ticket]On Wed Jul 30 14:51:25 2014, chr.stahlhut@gmail.com wrote:
To be more precise, this happens: christian@azmodan ~ $ perl -d ./debug-me.pl Loading DB routines from perl5db.pl version 1.39_10 Enter h or 'h h' for help, or 'man perldebug' for more help. main::(./debug-me.pl:4): $DB::single=2; |
From @jkeenanOn Wed Jul 30 14:55:21 2014, chr.stahlhut@gmail.com wrote:
I can reproduce this with the perls available via perlbrew at least as far back as 5.10.1: ##### This is perl, v5.10.1 (*) built for x86_64-linux Copyright 1987-2009, Larry Wall [p5p] 40 $ perl -d 122445-debug-me.pl Loading DB routines from perl5db.pl version 1.32 Enter h or `h h' for help, or `man perldebug' for more help. main::(122445-debug-me.pl:4): $DB::single=2; |
|
The RT System itself - Status changed from 'new' to 'open' |
From @jkeenanOn Wed Jul 30 14:55:21 2014, chr.stahlhut@gmail.com wrote:
Is it possible that you are using $DB::single in a manner for which is not intended? In the documenation to DB.pm, I read: ##### The following "public" global names can be read by clients [snip] $DB::single Single-step flag. Will be true if the API will You are trying to assign to $DB::single, which seems to violate the "readonly" stipulation. Moreover, when I hear something described as a "flag", my first impulse is to think of it as a Boolean with 1 usually representing True and 0 representing False. (Granted there is one point in DB.pm where a value of 2 is assigned to $DB::single.) I don't claim to speak definitively here. Thank you very much. |
From @JohnPeacockOn 07/30/2014 09:34 PM, James E Keenan via RT wrote:
Setting a debugging break programatically by assigning to $DB::single is http://perldoc.perl.org/perldebug.html and incredibly useful (hint, you can also set it conditionally to break John |
From @tonycozOn Wed Jul 30 14:55:21 2014, chr.stahlhut@gmail.com wrote:
This appears to be happening in the debugger at line 4146: (gdb) p my_perl->Icurcop->cop_line when it tries to execute: # Turn off all flags except single-stepping. Partial backtrace: #0 Perl_Gv_AMupdate (my_perl=my_perl@entry=0x602010, stash=0xa28678, Here's the bottom of the trace when I broke in earlier (I stopped looking at 30000 on the full backtrace): #460 0x00007ffff79cc34d in Perl_runops_debug (my_perl=0x602010) at dump.c:2361 The start of the recursion is the call to SvIV(PL_DBsingle) in pp_dbstate. As a workaround, you can disable bignum for the $DB::single assignment: Loading DB routines from perl5db.pl version 1.45 Enter h or 'h h' for help, or 'man perldebug' for more help. main::(../debug-me.pl:4): { no bignum; $DB::single=2; } I don't see a simple fix, I think we'd need to add set and get magic to $DB::single (and possibly to $DB::signal and $DB::trace) that stores the values as in IVs in my_perl rather than SVs with their possible unwanted magic. Tony |
From chr.stahlhut@gmail.comThe workaround does it for me, thank you! |
From [Unknown Contact. See original ticket]The workaround does it for me, thank you! |
From @tonycozOn Sun Aug 03 19:12:14 2014, tonyc wrote:
Attached is a test and a patch that does just that. This is my first time implementing magic. Tony |
From @tonycoz0001-perl-122445-test-for-overload-assigned-to-DB-single.patchFrom c58dab6ae371e8b8d20ab9445a4eca168bc388c9 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 14 Aug 2014 11:09:10 +1000
Subject: [perl #122445] test for overload assigned to $DB::single
---
t/run/switchd.t | 20 +++++++++++++++++++-
1 file changed, 19 insertions(+), 1 deletion(-)
diff --git a/t/run/switchd.t b/t/run/switchd.t
index b5d4d42..4958ce7 100644
--- a/t/run/switchd.t
+++ b/t/run/switchd.t
@@ -9,7 +9,7 @@ BEGIN { require "./test.pl"; }
# This test depends on t/lib/Devel/switchd*.pm.
-plan(tests => 18);
+plan(tests => 19);
my $r;
@@ -275,3 +275,21 @@ is(
"42\n",
'UTF8 length caches on $DB::sub are flushed'
);
+
+{
+local $TODO = "This crashes";
+is(
+ runperl(
+ switches => [ '-Ilib', '-d:switchd_empty' ],
+ progs => [ split "\n",
+ 'use bignum;
+ $DB::single=2;
+ print qq/debugged\n/;
+ '
+ ],
+ stderr => 1
+ ),
+ "debugged\n",
+ "\$DB::single set to overload"
+);
+}
--
1.7.10.4
|
From @tonycoz0002-perl-122445-use-magic-on-DB-single-etc-to-avoid-over.patchFrom 8e1d231cb12e865e16527390965136f0d2213bb8 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 14 Aug 2014 11:19:22 +1000
Subject: [perl #122445] use magic on $DB::single etc to avoid overload issues
This prevents perl recursing infinitely when an overloaded object is
assigned to $DB::single, $DB::trace or $DB::signal
This is done by referencing their values as IVs instead of as SVs in
dbstate, and by adding magic to those variables so that assignments to
the scalars update the _iv variables.
---
embed.fnc | 2 ++
embed.h | 2 ++
embedvar.h | 3 +++
intrpvar.h | 4 ++++
mg.c | 48 ++++++++++++++++++++++++++++++++++++++++++++++++
mg_names.c | 1 +
mg_raw.h | 2 ++
mg_vtable.h | 5 +++++
perl.c | 18 +++++++++++++++++-
perl.h | 10 ++++++++++
pod/perlguts.pod | 2 ++
pp_ctl.c | 2 +-
proto.h | 12 ++++++++++++
regen/mg_vtable.pl | 3 +++
sv.c | 3 +++
t/run/switchd.t | 3 ---
16 files changed, 115 insertions(+), 5 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index b70404d..97e31d4 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -823,6 +823,7 @@ p |int |magic_freeovrld|NN SV* sv|NN MAGIC* mg
p |int |magic_get |NN SV* sv|NN MAGIC* mg
p |int |magic_getarylen|NN SV* sv|NN const MAGIC* mg
p |int |magic_getdefelem|NN SV* sv|NN MAGIC* mg
+p |int |magic_getdebugvar|NN SV* sv|NN MAGIC* mg
p |int |magic_getnkeys |NN SV* sv|NN MAGIC* mg
p |int |magic_getpack |NN SV* sv|NN MAGIC* mg
p |int |magic_getpos |NN SV* sv|NN MAGIC* mg
@@ -846,6 +847,7 @@ p |int |magic_setarylen|NN SV* sv|NN MAGIC* mg
p |int |magic_cleararylen_p|NN SV* sv|NN MAGIC* mg
p |int |magic_freearylen_p|NN SV* sv|NN MAGIC* mg
p |int |magic_setdbline|NN SV* sv|NN MAGIC* mg
+p |int |magic_setdebugvar|NN SV* sv|NN MAGIC* mg
p |int |magic_setdefelem|NN SV* sv|NN MAGIC* mg
p |int |magic_setenv |NN SV* sv|NN MAGIC* mg
dp |int |magic_sethint |NN SV* sv|NN MAGIC* mg
diff --git a/embed.h b/embed.h
index 3962901..5b1578f 100644
--- a/embed.h
+++ b/embed.h
@@ -1184,6 +1184,7 @@
#define magic_freeovrld(a,b) Perl_magic_freeovrld(aTHX_ a,b)
#define magic_get(a,b) Perl_magic_get(aTHX_ a,b)
#define magic_getarylen(a,b) Perl_magic_getarylen(aTHX_ a,b)
+#define magic_getdebugvar(a,b) Perl_magic_getdebugvar(aTHX_ a,b)
#define magic_getdefelem(a,b) Perl_magic_getdefelem(aTHX_ a,b)
#define magic_getnkeys(a,b) Perl_magic_getnkeys(aTHX_ a,b)
#define magic_getpack(a,b) Perl_magic_getpack(aTHX_ a,b)
@@ -1202,6 +1203,7 @@
#define magic_set_all_env(a,b) Perl_magic_set_all_env(aTHX_ a,b)
#define magic_setarylen(a,b) Perl_magic_setarylen(aTHX_ a,b)
#define magic_setdbline(a,b) Perl_magic_setdbline(aTHX_ a,b)
+#define magic_setdebugvar(a,b) Perl_magic_setdebugvar(aTHX_ a,b)
#define magic_setdefelem(a,b) Perl_magic_setdefelem(aTHX_ a,b)
#define magic_setenv(a,b) Perl_magic_setenv(aTHX_ a,b)
#define magic_sethint(a,b) Perl_magic_sethint(aTHX_ a,b)
diff --git a/embedvar.h b/embedvar.h
index 454c1ee..a6aee7d 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -47,9 +47,12 @@
#define PL_DBgv (vTHX->IDBgv)
#define PL_DBline (vTHX->IDBline)
#define PL_DBsignal (vTHX->IDBsignal)
+#define PL_DBsignal_iv (vTHX->IDBsignal_iv)
#define PL_DBsingle (vTHX->IDBsingle)
+#define PL_DBsingle_iv (vTHX->IDBsingle_iv)
#define PL_DBsub (vTHX->IDBsub)
#define PL_DBtrace (vTHX->IDBtrace)
+#define PL_DBtrace_iv (vTHX->IDBtrace_iv)
#define PL_Dir (vTHX->IDir)
#define PL_Env (vTHX->IEnv)
#define PL_HasMultiCharFold (vTHX->IHasMultiCharFold)
diff --git a/intrpvar.h b/intrpvar.h
index 9dd4e16..a8fa1ef 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -390,6 +390,10 @@ PERLVAR(I, DBtrace, SV *) /* $DB::trace */
PERLVAR(I, DBsignal, SV *) /* $DB::signal */
PERLVAR(I, dbargs, AV *) /* args to call listed by caller function */
+PERLVAR(I, DBsingle_iv, IV)
+PERLVAR(I, DBtrace_iv, IV)
+PERLVAR(I, DBsignal_iv, IV)
+
/* symbol tables */
PERLVAR(I, debstash, HV *) /* symbol table for perldb package */
PERLVAR(I, globalstash, HV *) /* global keyword overrides imported here */
diff --git a/mg.c b/mg.c
index e1fc578..82eae84 100644
--- a/mg.c
+++ b/mg.c
@@ -3397,6 +3397,54 @@ Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
return 1;
}
+int
+Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
+ PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
+
+ switch (mg->mg_private) {
+ case DBVARMG_SINGLE:
+ PL_DBsingle_iv = SvIV_nomg(sv);
+ break;
+
+ case DBVARMG_TRACE:
+ PL_DBtrace_iv = SvIV_nomg(sv);
+ break;
+
+ case DBVARMG_SIGNAL:
+ PL_DBsignal_iv = SvIV_nomg(sv);
+ break;
+
+ default:
+ NOT_REACHED;
+ }
+
+ return 1;
+}
+
+int
+Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
+ PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
+
+ switch (mg->mg_private) {
+ case DBVARMG_SINGLE:
+ sv_setiv(sv, PL_DBsingle_iv);
+ break;
+
+ case DBVARMG_TRACE:
+ sv_setiv(sv, PL_DBtrace_iv);
+ break;
+
+ case DBVARMG_SIGNAL:
+ sv_setiv(sv, PL_DBsignal_iv);
+ break;
+
+ default:
+ NOT_REACHED;
+ }
+
+ return 0;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
diff --git a/mg_names.c b/mg_names.c
index 73dc3f9..52eed71 100644
--- a/mg_names.c
+++ b/mg_names.c
@@ -10,6 +10,7 @@
{ PERL_MAGIC_arylen, "arylen(#)" },
{ PERL_MAGIC_rhash, "rhash(%)" },
{ PERL_MAGIC_proto, "proto(&)" },
+ { PERL_MAGIC_debugvar, "debugvar(*)" },
{ PERL_MAGIC_pos, "pos(.)" },
{ PERL_MAGIC_symtab, "symtab(:)" },
{ PERL_MAGIC_backref, "backref(<)" },
diff --git a/mg_raw.h b/mg_raw.h
index f508ad0..984f1d7 100644
--- a/mg_raw.h
+++ b/mg_raw.h
@@ -14,6 +14,8 @@
"/* rhash '%' extra data for restricted hashes */" },
{ '&', "magic_vtable_max",
"/* proto '&' my sub prototype CV */" },
+ { '*', "want_vtbl_debugvar",
+ "/* debugvar '*' $DB::single, signal, trace vars */" },
{ '.', "want_vtbl_pos | PERL_MAGIC_VALUE_MAGIC",
"/* pos '.' pos() lvalue */" },
{ ':', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
diff --git a/mg_vtable.h b/mg_vtable.h
index f391713..104e936 100644
--- a/mg_vtable.h
+++ b/mg_vtable.h
@@ -16,6 +16,7 @@
#define PERL_MAGIC_arylen '#' /* Array length ($#ary) */
#define PERL_MAGIC_rhash '%' /* extra data for restricted hashes */
#define PERL_MAGIC_proto '&' /* my sub prototype CV */
+#define PERL_MAGIC_debugvar '*' /* $DB::single, signal, trace vars */
#define PERL_MAGIC_pos '.' /* pos() lvalue */
#define PERL_MAGIC_symtab ':' /* extra data for symbol tables */
#define PERL_MAGIC_backref '<' /* for weak ref data */
@@ -64,6 +65,7 @@ enum { /* pass one of these to get_vtbl */
want_vtbl_checkcall,
want_vtbl_collxfrm,
want_vtbl_dbline,
+ want_vtbl_debugvar,
want_vtbl_defelem,
want_vtbl_env,
want_vtbl_envelem,
@@ -98,6 +100,7 @@ EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
"checkcall",
"collxfrm",
"dbline",
+ "debugvar",
"defelem",
"env",
"envelem",
@@ -155,6 +158,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
{ 0, 0, 0, 0, 0, 0, 0, 0 },
#endif
{ 0, Perl_magic_setdbline, 0, 0, 0, 0, 0, 0 },
+ { Perl_magic_getdebugvar, Perl_magic_setdebugvar, 0, 0, 0, 0, 0, 0 },
{ Perl_magic_getdefelem, Perl_magic_setdefelem, 0, 0, 0, 0, 0, 0 },
{ 0, Perl_magic_set_all_env, 0, Perl_magic_clear_all_env, 0, 0, 0, 0 },
{ 0, Perl_magic_setenv, 0, Perl_magic_clearenv, 0, 0, 0, 0 },
@@ -197,6 +201,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
#define PL_vtbl_checkcall PL_magic_vtables[want_vtbl_checkcall]
#define PL_vtbl_collxfrm PL_magic_vtables[want_vtbl_collxfrm]
#define PL_vtbl_dbline PL_magic_vtables[want_vtbl_dbline]
+#define PL_vtbl_debugvar PL_magic_vtables[want_vtbl_debugvar]
#define PL_vtbl_defelem PL_magic_vtables[want_vtbl_defelem]
#define PL_vtbl_env PL_magic_vtables[want_vtbl_env]
#define PL_vtbl_envelem PL_magic_vtables[want_vtbl_envelem]
diff --git a/perl.c b/perl.c
index e84f1d5..cb14726 100644
--- a/perl.c
+++ b/perl.c
@@ -968,6 +968,9 @@ perl_destruct(pTHXx)
PL_DBsingle = NULL;
PL_DBtrace = NULL;
PL_DBsignal = NULL;
+ PL_DBsingle_iv = 0;
+ PL_DBtrace_iv = 0;
+ PL_DBsignal_iv = 0;
PL_DBcv = NULL;
PL_dbargs = NULL;
PL_debstash = NULL;
@@ -2386,7 +2389,7 @@ S_run_body(pTHX_ I32 oldscope)
my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
- sv_setiv(PL_DBsingle, 1);
+ PL_DBsingle_iv = 1;
if (PL_initav) {
PERL_SET_PHASE(PERL_PHASE_INIT);
call_list(oldscope, PL_initav);
@@ -3959,6 +3962,7 @@ void
Perl_init_debugger(pTHX)
{
HV * const ostash = PL_curstash;
+ MAGIC *mg;
PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
@@ -3975,12 +3979,24 @@ Perl_init_debugger(pTHX)
PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsingle))
sv_setiv(PL_DBsingle, 0);
+ mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_SINGLE;
+ SvSETMAGIC(PL_DBsingle);
+
PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBtrace))
sv_setiv(PL_DBtrace, 0);
+ mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_TRACE;
+ SvSETMAGIC(PL_DBtrace);
+
PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsignal))
sv_setiv(PL_DBsignal, 0);
+ mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_SIGNAL;
+ SvSETMAGIC(PL_DBsignal);
+
SvREFCNT_dec(PL_curstash);
PL_curstash = ostash;
}
diff --git a/perl.h b/perl.h
index d03c0e8..110ed55 100644
--- a/perl.h
+++ b/perl.h
@@ -5924,6 +5924,16 @@ extern void moncontrol(int);
#define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
#define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE|PERL_PV_ESCAPE_NONASCII
+#ifdef PERL_CORE
+
+/* Used for debugvar magic */
+
+#define DBVARMG_SINGLE 0
+#define DBVARMG_TRACE 1
+#define DBVARMG_SIGNAL 2
+
+#endif
+
/*
(KEEP THIS LAST IN perl.h!)
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index bcd2672..fbfa9cb 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -1169,6 +1169,8 @@ will be lost.
% PERL_MAGIC_rhash (none) extra data for restricted
hashes
& PERL_MAGIC_proto (none) my sub prototype CV
+ * PERL_MAGIC_debugvar vtbl_debugvar $DB::single, signal, trace
+ vars
. PERL_MAGIC_pos vtbl_pos pos() lvalue
: PERL_MAGIC_symtab (none) extra data for symbol
tables
diff --git a/pp_ctl.c b/pp_ctl.c
index 5e671ee..aca051e 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1943,7 +1943,7 @@ PP(pp_dbstate)
PERL_ASYNC_CHECK();
if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
- || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
+ || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
{
dSP;
PERL_CONTEXT *cx;
diff --git a/proto.h b/proto.h
index 1e42903..5359c92 100644
--- a/proto.h
+++ b/proto.h
@@ -2316,6 +2316,12 @@ PERL_CALLCONV int Perl_magic_getarylen(pTHX_ SV* sv, const MAGIC* mg)
#define PERL_ARGS_ASSERT_MAGIC_GETARYLEN \
assert(sv); assert(mg)
+PERL_CALLCONV int Perl_magic_getdebugvar(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR \
+ assert(sv); assert(mg)
+
PERL_CALLCONV int Perl_magic_getdefelem(pTHX_ SV* sv, MAGIC* mg)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
@@ -2432,6 +2438,12 @@ PERL_CALLCONV int Perl_magic_setdbline(pTHX_ SV* sv, MAGIC* mg)
#define PERL_ARGS_ASSERT_MAGIC_SETDBLINE \
assert(sv); assert(mg)
+PERL_CALLCONV int Perl_magic_setdebugvar(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR \
+ assert(sv); assert(mg)
+
PERL_CALLCONV int Perl_magic_setdefelem(pTHX_ SV* sv, MAGIC* mg)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl
index 0bbfbfd..51c1306 100644
--- a/regen/mg_vtable.pl
+++ b/regen/mg_vtable.pl
@@ -108,6 +108,8 @@ my %mg =
ext => { char => '~', desc => 'Available for use by extensions' },
checkcall => { char => ']', value_magic => 1, vtable => 'checkcall',
desc => 'inlining/mutation of call to this CV'},
+ debugvar => { char => '*', desc => '$DB::single, signal, trace vars',
+ vtable => 'debugvar' },
);
# These have a subtly different "namespace" from the magic types.
@@ -144,6 +146,7 @@ my %sig =
'hintselem' => {set => 'sethint', clear => 'clearhint'},
'hints' => {clear => 'clearhints'},
'checkcall' => {copy => 'copycallchecker'},
+ 'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' },
);
my ($vt, $raw, $names) = map {
diff --git a/sv.c b/sv.c
index afd4376..a7a41dd 100644
--- a/sv.c
+++ b/sv.c
@@ -13819,6 +13819,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
+ PL_DBsingle_iv = proto_perl->IDBsingle_iv;
+ PL_DBtrace_iv = proto_perl->IDBtrace_iv;
+ PL_DBsignal_iv = proto_perl->IDBsignal_iv;
/* symbol tables */
PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
diff --git a/t/run/switchd.t b/t/run/switchd.t
index 4958ce7..ceabbfe 100644
--- a/t/run/switchd.t
+++ b/t/run/switchd.t
@@ -276,8 +276,6 @@ is(
'UTF8 length caches on $DB::sub are flushed'
);
-{
-local $TODO = "This crashes";
is(
runperl(
switches => [ '-Ilib', '-d:switchd_empty' ],
@@ -292,4 +290,3 @@ is(
"debugged\n",
"\$DB::single set to overload"
);
-}
--
1.7.10.4
|
From @cpansproutOn Wed Aug 13 18:25:26 2014, tonyc wrote:
Your patch looks good to me.
Congratulations! -- Father Chrysostomos |
From @bulk88On Wed Aug 13 18:25:26 2014, tonyc wrote:
Inline Patchdiff --git a/intrpvar.h b/intrpvar.h
index 9dd4e16..a8fa1ef 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -390,6 +390,10 @@ PERLVAR(I, DBtrace, SV *) /* $DB::trace */
PERLVAR(I, DBsignal, SV *) /* $DB::signal */
PERLVAR(I, dbargs, AV *) /* args to call listed by caller function */
+PERLVAR(I, DBsingle_iv, IV)
+PERLVAR(I, DBtrace_iv, IV)
+PERLVAR(I, DBsignal_iv, IV)
+
/* symbol tables */
PERLVAR(I, debstash, HV *) /* symbol table for perldb package */
PERLVAR(I, globalstash, HV *) /* global keyword overrides imported here */
Inline Patchdiff --git a/pp_ctl.c b/pp_ctl.c
index 5e671ee..aca051e 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1943,7 +1943,7 @@ PP(pp_dbstate)
PERL_ASYNC_CHECK();
if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
- || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
+ || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
{
dSP;
PERL_CONTEXT *cx;
+int Factor out the SvIV_nomg calls. Also instead of using the constants DBVARMG_* and mg_private, why not put the pointer to the IV (or whatever) into mg_ptr? then no more switch and the code is branchless. Interps can't be realloced. Inline Patchdiff --git a/mg_raw.h b/mg_raw.h
index f508ad0..984f1d7 100644
--- a/mg_raw.h
+++ b/mg_raw.h
@@ -14,6 +14,8 @@
"/* rhash '%' extra data for restricted hashes */" },
{ '&', "magic_vtable_max",
"/* proto '&' my sub prototype CV */" },
+ { '*', "want_vtbl_debugvar",
+ "/* debugvar '*' $DB::single, signal, trace vars */" },
{ '.', "want_vtbl_pos | PERL_MAGIC_VALUE_MAGIC",
"/* pos '.' pos() lvalue */" },
{ ':', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
instead of @@ -3975,12 +3979,24 @@ Perl_init_debugger(pTHX) how about @@ -3975,12 +3979,24 @@ Perl_init_debugger(pTHX) that will also require svt_dup function to update the pointer in mg_ptr to the one from the new interp. -- |
From @tonycozThanks for the feedback. On Fri Aug 15 04:47:22 2014, bulk88 wrote:
I considered this, but perl5db.pl stores flags in $DB::single and $DB::trace at least. Another debugger might use more flags.
Since I don't want to assumed limited sizes for these variables, I can't make this optimization.
I made the PL_*_iv variables into an array, which removed the switch and factored out the SvIV_nomg() calls.
When I wrote it I checked the core for use of PERL_MAGIC_ext and didn't find any, so I assumed it was best practice in core to add new magic. As you say, it makes the sv_dump() output more intelligible. Using the indexes as I've done also helps to make it readable. Tony |
From @tonycoz0002-perl-122445-use-magic-on-DB-single-etc-to-avoid-over.patchFrom bd4f4f6d975802435ad5925aede188a0f131907f Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 2 Oct 2014 15:54:58 +1000
Subject: [perl #122445] use magic on $DB::single etc to avoid overload issues
This prevents perl recursing infinitely when an overloaded object is
assigned to $DB::single, $DB::trace or $DB::signal
This is done by referencing their values as IVs instead of as SVs in
dbstate, and by adding magic to those variables so that assignments to
the scalars update the PL_DBcontrol array.
---
embed.fnc | 2 ++
embed.h | 2 ++
embedvar.h | 1 +
intrpvar.h | 2 ++
mg.c | 21 +++++++++++++++++++++
mg_names.c | 1 +
mg_raw.h | 2 ++
mg_vtable.h | 5 +++++
perl.c | 18 +++++++++++++++++-
perl.h | 10 ++++++++++
pod/perlguts.pod | 2 ++
pp_ctl.c | 2 +-
proto.h | 12 ++++++++++++
regen/mg_vtable.pl | 3 +++
sv.c | 1 +
t/run/switchd.t | 3 ---
16 files changed, 82 insertions(+), 5 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index 5de2f83..3def772 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -831,6 +831,7 @@ p |int |magic_freeovrld|NN SV* sv|NN MAGIC* mg
p |int |magic_get |NN SV* sv|NN MAGIC* mg
p |int |magic_getarylen|NN SV* sv|NN const MAGIC* mg
p |int |magic_getdefelem|NN SV* sv|NN MAGIC* mg
+p |int |magic_getdebugvar|NN SV* sv|NN MAGIC* mg
p |int |magic_getnkeys |NN SV* sv|NN MAGIC* mg
p |int |magic_getpack |NN SV* sv|NN MAGIC* mg
p |int |magic_getpos |NN SV* sv|NN MAGIC* mg
@@ -854,6 +855,7 @@ p |int |magic_setarylen|NN SV* sv|NN MAGIC* mg
p |int |magic_cleararylen_p|NN SV* sv|NN MAGIC* mg
p |int |magic_freearylen_p|NN SV* sv|NN MAGIC* mg
p |int |magic_setdbline|NN SV* sv|NN MAGIC* mg
+p |int |magic_setdebugvar|NN SV* sv|NN MAGIC* mg
p |int |magic_setdefelem|NN SV* sv|NN MAGIC* mg
p |int |magic_setenv |NN SV* sv|NN MAGIC* mg
dp |int |magic_sethint |NN SV* sv|NN MAGIC* mg
diff --git a/embed.h b/embed.h
index ed04c7c..bcd1f42 100644
--- a/embed.h
+++ b/embed.h
@@ -1200,6 +1200,7 @@
#define magic_freeovrld(a,b) Perl_magic_freeovrld(aTHX_ a,b)
#define magic_get(a,b) Perl_magic_get(aTHX_ a,b)
#define magic_getarylen(a,b) Perl_magic_getarylen(aTHX_ a,b)
+#define magic_getdebugvar(a,b) Perl_magic_getdebugvar(aTHX_ a,b)
#define magic_getdefelem(a,b) Perl_magic_getdefelem(aTHX_ a,b)
#define magic_getnkeys(a,b) Perl_magic_getnkeys(aTHX_ a,b)
#define magic_getpack(a,b) Perl_magic_getpack(aTHX_ a,b)
@@ -1218,6 +1219,7 @@
#define magic_set_all_env(a,b) Perl_magic_set_all_env(aTHX_ a,b)
#define magic_setarylen(a,b) Perl_magic_setarylen(aTHX_ a,b)
#define magic_setdbline(a,b) Perl_magic_setdbline(aTHX_ a,b)
+#define magic_setdebugvar(a,b) Perl_magic_setdebugvar(aTHX_ a,b)
#define magic_setdefelem(a,b) Perl_magic_setdefelem(aTHX_ a,b)
#define magic_setenv(a,b) Perl_magic_setenv(aTHX_ a,b)
#define magic_sethint(a,b) Perl_magic_sethint(aTHX_ a,b)
diff --git a/embedvar.h b/embedvar.h
index adc207d..2659d02 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -43,6 +43,7 @@
#define PL_AboveLatin1 (vTHX->IAboveLatin1)
#define PL_Argv (vTHX->IArgv)
#define PL_Cmd (vTHX->ICmd)
+#define PL_DBcontrol (vTHX->IDBcontrol)
#define PL_DBcv (vTHX->IDBcv)
#define PL_DBgv (vTHX->IDBgv)
#define PL_DBline (vTHX->IDBline)
diff --git a/intrpvar.h b/intrpvar.h
index ee1d3ed..a5248a8 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -393,6 +393,8 @@ PERLVAR(I, DBtrace, SV *) /* $DB::trace */
PERLVAR(I, DBsignal, SV *) /* $DB::signal */
PERLVAR(I, dbargs, AV *) /* args to call listed by caller function */
+PERLVARA(I, DBcontrol, DBVARMG_COUNT, IV) /* IV versions of $DB::single, trace, signal */
+
/* symbol tables */
PERLVAR(I, debstash, HV *) /* symbol table for perldb package */
PERLVAR(I, globalstash, HV *) /* global keyword overrides imported here */
diff --git a/mg.c b/mg.c
index 5566372..9653c70 100644
--- a/mg.c
+++ b/mg.c
@@ -3403,6 +3403,27 @@ Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
return 1;
}
+int
+Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
+ PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
+
+ assert(mg->mg_private >= DBVARMG_SINGLE && mg->mg_private < DBVARMG_COUNT);
+
+ PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
+
+ return 1;
+}
+
+int
+Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
+ PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
+
+ assert(mg->mg_private >= DBVARMG_SINGLE && mg->mg_private < DBVARMG_COUNT);
+ sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
+
+ return 0;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
diff --git a/mg_names.c b/mg_names.c
index 73dc3f9..52eed71 100644
--- a/mg_names.c
+++ b/mg_names.c
@@ -10,6 +10,7 @@
{ PERL_MAGIC_arylen, "arylen(#)" },
{ PERL_MAGIC_rhash, "rhash(%)" },
{ PERL_MAGIC_proto, "proto(&)" },
+ { PERL_MAGIC_debugvar, "debugvar(*)" },
{ PERL_MAGIC_pos, "pos(.)" },
{ PERL_MAGIC_symtab, "symtab(:)" },
{ PERL_MAGIC_backref, "backref(<)" },
diff --git a/mg_raw.h b/mg_raw.h
index f508ad0..984f1d7 100644
--- a/mg_raw.h
+++ b/mg_raw.h
@@ -14,6 +14,8 @@
"/* rhash '%' extra data for restricted hashes */" },
{ '&', "magic_vtable_max",
"/* proto '&' my sub prototype CV */" },
+ { '*', "want_vtbl_debugvar",
+ "/* debugvar '*' $DB::single, signal, trace vars */" },
{ '.', "want_vtbl_pos | PERL_MAGIC_VALUE_MAGIC",
"/* pos '.' pos() lvalue */" },
{ ':', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
diff --git a/mg_vtable.h b/mg_vtable.h
index f391713..104e936 100644
--- a/mg_vtable.h
+++ b/mg_vtable.h
@@ -16,6 +16,7 @@
#define PERL_MAGIC_arylen '#' /* Array length ($#ary) */
#define PERL_MAGIC_rhash '%' /* extra data for restricted hashes */
#define PERL_MAGIC_proto '&' /* my sub prototype CV */
+#define PERL_MAGIC_debugvar '*' /* $DB::single, signal, trace vars */
#define PERL_MAGIC_pos '.' /* pos() lvalue */
#define PERL_MAGIC_symtab ':' /* extra data for symbol tables */
#define PERL_MAGIC_backref '<' /* for weak ref data */
@@ -64,6 +65,7 @@ enum { /* pass one of these to get_vtbl */
want_vtbl_checkcall,
want_vtbl_collxfrm,
want_vtbl_dbline,
+ want_vtbl_debugvar,
want_vtbl_defelem,
want_vtbl_env,
want_vtbl_envelem,
@@ -98,6 +100,7 @@ EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
"checkcall",
"collxfrm",
"dbline",
+ "debugvar",
"defelem",
"env",
"envelem",
@@ -155,6 +158,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
{ 0, 0, 0, 0, 0, 0, 0, 0 },
#endif
{ 0, Perl_magic_setdbline, 0, 0, 0, 0, 0, 0 },
+ { Perl_magic_getdebugvar, Perl_magic_setdebugvar, 0, 0, 0, 0, 0, 0 },
{ Perl_magic_getdefelem, Perl_magic_setdefelem, 0, 0, 0, 0, 0, 0 },
{ 0, Perl_magic_set_all_env, 0, Perl_magic_clear_all_env, 0, 0, 0, 0 },
{ 0, Perl_magic_setenv, 0, Perl_magic_clearenv, 0, 0, 0, 0 },
@@ -197,6 +201,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
#define PL_vtbl_checkcall PL_magic_vtables[want_vtbl_checkcall]
#define PL_vtbl_collxfrm PL_magic_vtables[want_vtbl_collxfrm]
#define PL_vtbl_dbline PL_magic_vtables[want_vtbl_dbline]
+#define PL_vtbl_debugvar PL_magic_vtables[want_vtbl_debugvar]
#define PL_vtbl_defelem PL_magic_vtables[want_vtbl_defelem]
#define PL_vtbl_env PL_magic_vtables[want_vtbl_env]
#define PL_vtbl_envelem PL_magic_vtables[want_vtbl_envelem]
diff --git a/perl.c b/perl.c
index 478b415..241ea31 100644
--- a/perl.c
+++ b/perl.c
@@ -968,6 +968,9 @@ perl_destruct(pTHXx)
PL_DBsingle = NULL;
PL_DBtrace = NULL;
PL_DBsignal = NULL;
+ PL_DBsingle_iv = 0;
+ PL_DBtrace_iv = 0;
+ PL_DBsignal_iv = 0;
PL_DBcv = NULL;
PL_dbargs = NULL;
PL_debstash = NULL;
@@ -2389,7 +2392,7 @@ S_run_body(pTHX_ I32 oldscope)
my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
- sv_setiv(PL_DBsingle, 1);
+ PL_DBsingle_iv = 1;
if (PL_initav) {
PERL_SET_PHASE(PERL_PHASE_INIT);
call_list(oldscope, PL_initav);
@@ -3962,6 +3965,7 @@ void
Perl_init_debugger(pTHX)
{
HV * const ostash = PL_curstash;
+ MAGIC *mg;
PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
@@ -3978,12 +3982,24 @@ Perl_init_debugger(pTHX)
PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsingle))
sv_setiv(PL_DBsingle, 0);
+ mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_SINGLE;
+ SvSETMAGIC(PL_DBsingle);
+
PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBtrace))
sv_setiv(PL_DBtrace, 0);
+ mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_TRACE;
+ SvSETMAGIC(PL_DBtrace);
+
PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsignal))
sv_setiv(PL_DBsignal, 0);
+ mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_SIGNAL;
+ SvSETMAGIC(PL_DBsignal);
+
SvREFCNT_dec(PL_curstash);
PL_curstash = ostash;
}
diff --git a/perl.h b/perl.h
index 436c7d1..065134c 100644
--- a/perl.h
+++ b/perl.h
@@ -5247,6 +5247,16 @@ typedef enum {
(SAWAMPERSAND_LEFT|SAWAMPERSAND_MIDDLE|SAWAMPERSAND_RIGHT)
#endif
+/* Used for debugvar magic */
+#define DBVARMG_SINGLE 0
+#define DBVARMG_TRACE 1
+#define DBVARMG_SIGNAL 2
+#define DBVARMG_COUNT 3
+
+#define PL_DBsingle_iv (PL_DBcontrol[DBVARMG_SINGLE])
+#define PL_DBtrace_iv (PL_DBcontrol[DBVARMG_TRACE])
+#define PL_DBsignal_iv (PL_DBcontrol[DBVARMG_SIGNAL])
+
/* Various states of the input record separator SV (rs) */
#define RsSNARF(sv) (! SvOK(sv))
#define RsSIMPLE(sv) (SvOK(sv) && (! SvPOK(sv) || SvCUR(sv)))
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 466f966..b70ead0 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -1169,6 +1169,8 @@ will be lost.
% PERL_MAGIC_rhash (none) extra data for restricted
hashes
& PERL_MAGIC_proto (none) my sub prototype CV
+ * PERL_MAGIC_debugvar vtbl_debugvar $DB::single, signal, trace
+ vars
. PERL_MAGIC_pos vtbl_pos pos() lvalue
: PERL_MAGIC_symtab (none) extra data for symbol
tables
diff --git a/pp_ctl.c b/pp_ctl.c
index d72ec1c..0b6980e 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1939,7 +1939,7 @@ PP(pp_dbstate)
PERL_ASYNC_CHECK();
if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
- || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
+ || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
{
dSP;
PERL_CONTEXT *cx;
diff --git a/proto.h b/proto.h
index bd6234f..949d1b5 100644
--- a/proto.h
+++ b/proto.h
@@ -2350,6 +2350,12 @@ PERL_CALLCONV int Perl_magic_getarylen(pTHX_ SV* sv, const MAGIC* mg)
#define PERL_ARGS_ASSERT_MAGIC_GETARYLEN \
assert(sv); assert(mg)
+PERL_CALLCONV int Perl_magic_getdebugvar(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR \
+ assert(sv); assert(mg)
+
PERL_CALLCONV int Perl_magic_getdefelem(pTHX_ SV* sv, MAGIC* mg)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
@@ -2466,6 +2472,12 @@ PERL_CALLCONV int Perl_magic_setdbline(pTHX_ SV* sv, MAGIC* mg)
#define PERL_ARGS_ASSERT_MAGIC_SETDBLINE \
assert(sv); assert(mg)
+PERL_CALLCONV int Perl_magic_setdebugvar(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR \
+ assert(sv); assert(mg)
+
PERL_CALLCONV int Perl_magic_setdefelem(pTHX_ SV* sv, MAGIC* mg)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl
index 0bbfbfd..51c1306 100644
--- a/regen/mg_vtable.pl
+++ b/regen/mg_vtable.pl
@@ -108,6 +108,8 @@ my %mg =
ext => { char => '~', desc => 'Available for use by extensions' },
checkcall => { char => ']', value_magic => 1, vtable => 'checkcall',
desc => 'inlining/mutation of call to this CV'},
+ debugvar => { char => '*', desc => '$DB::single, signal, trace vars',
+ vtable => 'debugvar' },
);
# These have a subtly different "namespace" from the magic types.
@@ -144,6 +146,7 @@ my %sig =
'hintselem' => {set => 'sethint', clear => 'clearhint'},
'hints' => {clear => 'clearhints'},
'checkcall' => {copy => 'copycallchecker'},
+ 'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' },
);
my ($vt, $raw, $names) = map {
diff --git a/sv.c b/sv.c
index 5f29137..764c91a 100644
--- a/sv.c
+++ b/sv.c
@@ -14578,6 +14578,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
+ Copy(proto_perl->IDBcontrol, PL_DBcontrol, DBVARMG_COUNT, IV);
/* symbol tables */
PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
diff --git a/t/run/switchd.t b/t/run/switchd.t
index 4958ce7..ceabbfe 100644
--- a/t/run/switchd.t
+++ b/t/run/switchd.t
@@ -276,8 +276,6 @@ is(
'UTF8 length caches on $DB::sub are flushed'
);
-{
-local $TODO = "This crashes";
is(
runperl(
switches => [ '-Ilib', '-d:switchd_empty' ],
@@ -292,4 +290,3 @@ is(
"debugged\n",
"\$DB::single set to overload"
);
-}
--
1.7.10.4
|
|
@tonycoz - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#122445 (status was 'resolved')
Searchable as RT122445$
The text was updated successfully, but these errors were encountered: