sv_catpv(t, "(");
unref++;
}
- else if (DEBUG_R_TEST && SvREFCNT(sv) > 1) {
+ else if (DEBUG_R_TEST_ && SvREFCNT(sv) > 1) {
Perl_sv_catpvf(aTHX_ t, "<%"UVuf">", (UV)SvREFCNT(sv));
}
{
do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
}
+
+int
+Perl_runops_debug(pTHX)
+{
+ if (!PL_op) {
+ if (ckWARN_d(WARN_DEBUGGING))
+ Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN");
+ return 0;
+ }
+
+ do {
+ PERL_ASYNC_CHECK();
+ if (PL_debug) {
+ if (PL_watchaddr != 0 && *PL_watchaddr != PL_watchok)
+ PerlIO_printf(Perl_debug_log,
+ "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
+ PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
+ PTR2UV(*PL_watchaddr));
+ if (DEBUG_p_TEST_) debstack();
+ if (DEBUG_t_TEST_) debop(PL_op);
+ if (DEBUG_P_TEST_) debprof(PL_op);
+ }
+ } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
+
+ TAINT_NOT;
+ return 0;
+}
+
+I32
+Perl_debop(pTHX_ OP *o)
+{
+ AV *padlist, *comppad;
+ CV *cv;
+ SV *sv;
+ STRLEN n_a;
+ Perl_deb(aTHX_ "%s", OP_NAME(o));
+ switch (o->op_type) {
+ case OP_CONST:
+ PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
+ break;
+ case OP_GVSV:
+ case OP_GV:
+ if (cGVOPo_gv) {
+ sv = NEWSV(0,0);
+ gv_fullname3(sv, cGVOPo_gv, Nullch);
+ PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, n_a));
+ SvREFCNT_dec(sv);
+ }
+ else
+ PerlIO_printf(Perl_debug_log, "(NULL)");
+ break;
+ case OP_PADSV:
+ case OP_PADAV:
+ case OP_PADHV:
+ /* print the lexical's name */
+ cv = deb_curcv(cxstack_ix);
+ if (cv) {
+ padlist = CvPADLIST(cv);
+ comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
+ sv = *av_fetch(comppad, o->op_targ, FALSE);
+ } else
+ sv = Nullsv;
+ if (sv)
+ PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv));
+ else
+ PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
+ break;
+ default:
+ break;
+ }
+ PerlIO_printf(Perl_debug_log, "\n");
+ return 0;
+}
+
+STATIC CV*
+S_deb_curcv(pTHX_ I32 ix)
+{
+ PERL_CONTEXT *cx = &cxstack[ix];
+ if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
+ return cx->blk_sub.cv;
+ else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
+ return PL_compcv;
+ else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
+ return PL_main_cv;
+ else if (ix <= 0)
+ return Nullcv;
+ else
+ return deb_curcv(ix - 1);
+}
+
+void
+Perl_watch(pTHX_ char **addr)
+{
+ PL_watchaddr = addr;
+ PL_watchok = *addr;
+ PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
+ PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
+}
+
+STATIC void
+S_debprof(pTHX_ OP *o)
+{
+ if (!PL_profiledata)
+ Newz(000, PL_profiledata, MAXO, U32);
+ ++PL_profiledata[o->op_type];
+}
+
+void
+Perl_debprofdump(pTHX)
+{
+ unsigned i;
+ if (!PL_profiledata)
+ return;
+ for (i = 0; i < MAXO; i++) {
+ if (PL_profiledata[i])
+ PerlIO_printf(Perl_debug_log,
+ "%5lu %s\n", (unsigned long)PL_profiledata[i],
+ PL_op_name[i]);
+ }
+}
#define reghopmaybe3 S_reghopmaybe3
#define find_byclass S_find_byclass
#endif
-#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
-# ifdef DEBUGGING
+#if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT)
#define deb_curcv S_deb_curcv
#define debprof S_debprof
-# endif
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
#define save_scalar_at S_save_scalar_at
#define reghopmaybe3(a,b,c) S_reghopmaybe3(aTHX_ a,b,c)
#define find_byclass(a,b,c,d,e,f) S_find_byclass(aTHX_ a,b,c,d,e,f)
#endif
-#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
-# ifdef DEBUGGING
+#if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT)
#define deb_curcv(a) S_deb_curcv(aTHX_ a)
#define debprof(a) S_debprof(aTHX_ a)
-# endif
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
#define save_scalar_at(a) S_save_scalar_at(aTHX_ a)
s |char* |find_byclass |regexp * prog|regnode *c|char *s|char *strend|char *startpos|I32 norun
#endif
-#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
-# ifdef DEBUGGING
+#if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT)
s |CV* |deb_curcv |I32 ix
s |void |debprof |OP *o
-# endif
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
package Devel::Peek;
# Underscore to allow older Perls to access older version from CPAN
-$VERSION = '1.00_02';
+$VERSION = '1.00_03';
require Exporter;
use XSLoader ();
@ISA = qw(Exporter);
@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg
- fill_mstats mstats_fillhash mstats2hash);
+ fill_mstats mstats_fillhash mstats2hash runops_debug debug_flags);
@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV);
%EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]);
Dump($_[0],$depth);
}
+$D_flags = 'psltocPmfrxuLHXDSTR';
+
+sub debug_flags (;$) {
+ my $out = "";
+ for my $i (0 .. length($D_flags)-1) {
+ $out .= substr $D_flags, $i, 1 if $^D & (1<<$i);
+ }
+ my $arg = shift;
+ my $num = $arg;
+ if (defined $arg and $arg =~ /\D/) {
+ die "unknown flags in debug_flags()" if $arg =~ /[^-$D_flags]/;
+ my ($on,$off) = split /-/, "$arg-";
+ $num = $^D;
+ $num |= (1<<index($D_flags, $_)) for split //, $on;
+ $num &= ~(1<<index($D_flags, $_)) for split //, $off;
+ }
+ $^D = $num if defined $arg;
+ $out
+}
+
1;
__END__
number of character printed in various string values. Setting it to 0
means no limit.
+=head2 Runtime debugging
+
+C<CvGV($cv)> return one of the globs associated to a subroutine reference $cv.
+
+debug_flags() returns a string representation of C<$^D> (similar to
+what is allowed for B<-D> flag). When called with a numeric argument,
+sets $^D to the corresponding value. When called with an argument of
+the form C<"flags-flags">, set on/off bits of C<$^D> corresponding to
+letters before/after C<->. (The returned value is for C<$^D> before
+the modification.)
+
+runops_debug() returns true if the current I<opcode dispatcher> is the
+debugging one. When called with an argument, switches to debugging or
+non-debugging dispatcher depending on the argument (active for
+newly-entered subs/etc only). (The returned value is for the dispatcher before the modification.)
+
=head2 Memory footprint debugging
When perl is compiled with support for memory footprint debugging
#include "perl.h"
#include "XSUB.h"
+bool
+_runops_debug(int flag)
+{
+ dTHX;
+ bool d = PL_runops == MEMBER_TO_FPTR(Perl_runops_debug);
+
+ if (flag >= 0)
+ PL_runops
+ = MEMBER_TO_FPTR(flag ? Perl_runops_debug : Perl_runops_standard);
+ return d;
+}
+
SV *
DeadCode(pTHX)
{
SV *
_CvGV(cv)
SV *cv
+
+bool
+_runops_debug(int flag = -1)
#define DEBUG_TOP_FLAG 0x80000000 /* XXX what's this for ??? */
+# define DEBUG_p_TEST_ (PL_debug & DEBUG_p_FLAG)
+# define DEBUG_s_TEST_ (PL_debug & DEBUG_s_FLAG)
+# define DEBUG_l_TEST_ (PL_debug & DEBUG_l_FLAG)
+# define DEBUG_t_TEST_ (PL_debug & DEBUG_t_FLAG)
+# define DEBUG_o_TEST_ (PL_debug & DEBUG_o_FLAG)
+# define DEBUG_c_TEST_ (PL_debug & DEBUG_c_FLAG)
+# define DEBUG_P_TEST_ (PL_debug & DEBUG_P_FLAG)
+# define DEBUG_m_TEST_ (PL_debug & DEBUG_m_FLAG)
+# define DEBUG_f_TEST_ (PL_debug & DEBUG_f_FLAG)
+# define DEBUG_r_TEST_ (PL_debug & DEBUG_r_FLAG)
+# define DEBUG_x_TEST_ (PL_debug & DEBUG_x_FLAG)
+# define DEBUG_u_TEST_ (PL_debug & DEBUG_u_FLAG)
+# define DEBUG_L_TEST_ (PL_debug & DEBUG_L_FLAG)
+# define DEBUG_H_TEST_ (PL_debug & DEBUG_H_FLAG)
+# define DEBUG_X_TEST_ (PL_debug & DEBUG_X_FLAG)
+# define DEBUG_D_TEST_ (PL_debug & DEBUG_D_FLAG)
+# define DEBUG_S_TEST_ (PL_debug & DEBUG_S_FLAG)
+# define DEBUG_T_TEST_ (PL_debug & DEBUG_T_FLAG)
+# define DEBUG_R_TEST_ (PL_debug & DEBUG_R_FLAG)
+
#ifdef DEBUGGING
# undef YYDEBUG
# define YYDEBUG 1
-# define DEBUG_p_TEST (PL_debug & DEBUG_p_FLAG)
-# define DEBUG_s_TEST (PL_debug & DEBUG_s_FLAG)
-# define DEBUG_l_TEST (PL_debug & DEBUG_l_FLAG)
-# define DEBUG_t_TEST (PL_debug & DEBUG_t_FLAG)
-# define DEBUG_o_TEST (PL_debug & DEBUG_o_FLAG)
-# define DEBUG_c_TEST (PL_debug & DEBUG_c_FLAG)
-# define DEBUG_P_TEST (PL_debug & DEBUG_P_FLAG)
-# define DEBUG_m_TEST (PL_debug & DEBUG_m_FLAG)
-# define DEBUG_f_TEST (PL_debug & DEBUG_f_FLAG)
-# define DEBUG_r_TEST (PL_debug & DEBUG_r_FLAG)
-# define DEBUG_x_TEST (PL_debug & DEBUG_x_FLAG)
-# define DEBUG_u_TEST (PL_debug & DEBUG_u_FLAG)
-# define DEBUG_L_TEST (PL_debug & DEBUG_L_FLAG)
-# define DEBUG_H_TEST (PL_debug & DEBUG_H_FLAG)
-# define DEBUG_X_TEST (PL_debug & DEBUG_X_FLAG)
-# define DEBUG_D_TEST (PL_debug & DEBUG_D_FLAG)
-# define DEBUG_S_TEST (PL_debug & DEBUG_S_FLAG)
-# define DEBUG_T_TEST (PL_debug & DEBUG_T_FLAG)
-# define DEBUG_R_TEST (PL_debug & DEBUG_R_FLAG)
+# define DEBUG_p_TEST DEBUG_p_TEST_
+# define DEBUG_s_TEST DEBUG_s_TEST_
+# define DEBUG_l_TEST DEBUG_l_TEST_
+# define DEBUG_t_TEST DEBUG_t_TEST_
+# define DEBUG_o_TEST DEBUG_o_TEST_
+# define DEBUG_c_TEST DEBUG_c_TEST_
+# define DEBUG_P_TEST DEBUG_P_TEST_
+# define DEBUG_m_TEST DEBUG_m_TEST_
+# define DEBUG_f_TEST DEBUG_f_TEST_
+# define DEBUG_r_TEST DEBUG_r_TEST_
+# define DEBUG_x_TEST DEBUG_x_TEST_
+# define DEBUG_u_TEST DEBUG_u_TEST_
+# define DEBUG_L_TEST DEBUG_L_TEST_
+# define DEBUG_H_TEST DEBUG_H_TEST_
+# define DEBUG_X_TEST DEBUG_X_TEST_
+# define DEBUG_D_TEST DEBUG_D_TEST_
+# define DEBUG_S_TEST DEBUG_S_TEST_
+# define DEBUG_T_TEST DEBUG_T_TEST_
+# define DEBUG_R_TEST DEBUG_R_TEST_
# define DEB(a) a
# define DEBUG(a) if (PL_debug) a
=item sharedsv_lock
Recursive locks on a sharedsv.
-Locks are dynamicly scoped at the level of the first lock.
+Locks are dynamically scoped at the level of the first lock.
void sharedsv_lock(shared_sv* ssv)
=for hackers
Function called by C<do_readline> to spawn a glob (or do the glob inside
perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
-this glob starter is only used by miniperl during the build proccess.
+this glob starter is only used by miniperl during the build process.
Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
PerlIO* start_glob(SV* pattern, IO *io)
STATIC char* S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *startpos, I32 norun);
#endif
-#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
-# ifdef DEBUGGING
+#if defined(PERL_IN_DUMP_C) || defined(PERL_DECL_PROT)
STATIC CV* S_deb_curcv(pTHX_ I32 ix);
STATIC void S_debprof(pTHX_ OP *o);
-# endif
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
return 0;
}
-int
-Perl_runops_debug(pTHX)
-{
-#ifdef DEBUGGING
- if (!PL_op) {
- if (ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN");
- return 0;
- }
-
- do {
- PERL_ASYNC_CHECK();
- if (PL_debug) {
- if (PL_watchaddr != 0 && *PL_watchaddr != PL_watchok)
- PerlIO_printf(Perl_debug_log,
- "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
- PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
- PTR2UV(*PL_watchaddr));
- DEBUG_s(debstack());
- DEBUG_t(debop(PL_op));
- DEBUG_P(debprof(PL_op));
- }
- } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
-
- TAINT_NOT;
- return 0;
-#else
- return runops_standard();
-#endif /* DEBUGGING */
-}
-
-I32
-Perl_debop(pTHX_ OP *o)
-{
-#ifdef DEBUGGING
- AV *padlist, *comppad;
- CV *cv;
- SV *sv;
- STRLEN n_a;
- Perl_deb(aTHX_ "%s", OP_NAME(o));
- switch (o->op_type) {
- case OP_CONST:
- PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
- break;
- case OP_GVSV:
- case OP_GV:
- if (cGVOPo_gv) {
- sv = NEWSV(0,0);
- gv_fullname3(sv, cGVOPo_gv, Nullch);
- PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, n_a));
- SvREFCNT_dec(sv);
- }
- else
- PerlIO_printf(Perl_debug_log, "(NULL)");
- break;
- case OP_PADSV:
- case OP_PADAV:
- case OP_PADHV:
- /* print the lexical's name */
- cv = deb_curcv(cxstack_ix);
- if (cv) {
- padlist = CvPADLIST(cv);
- comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
- sv = *av_fetch(comppad, o->op_targ, FALSE);
- } else
- sv = Nullsv;
- if (sv)
- PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv));
- else
- PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
- break;
- default:
- break;
- }
- PerlIO_printf(Perl_debug_log, "\n");
-#endif /* DEBUGGING */
- return 0;
-}
-
-#ifdef DEBUGGING
-
-STATIC CV*
-S_deb_curcv(pTHX_ I32 ix)
-{
- PERL_CONTEXT *cx = &cxstack[ix];
- if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
- return cx->blk_sub.cv;
- else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
- return PL_compcv;
- else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
- return PL_main_cv;
- else if (ix <= 0)
- return Nullcv;
- else
- return deb_curcv(ix - 1);
-}
-
-#endif /* DEBUGGING */
-
-void
-Perl_watch(pTHX_ char **addr)
-{
-#ifdef DEBUGGING
- PL_watchaddr = addr;
- PL_watchok = *addr;
- PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
- PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
-#endif /* DEBUGGING */
-}
-
-#ifdef DEBUGGING
-
-STATIC void
-S_debprof(pTHX_ OP *o)
-{
- if (!PL_profiledata)
- Newz(000, PL_profiledata, MAXO, U32);
- ++PL_profiledata[o->op_type];
-}
-
-#endif /* DEBUGGING */
-
-void
-Perl_debprofdump(pTHX)
-{
-#ifdef DEBUGGING
- unsigned i;
- if (!PL_profiledata)
- return;
- for (i = 0; i < MAXO; i++) {
- if (PL_profiledata[i])
- PerlIO_printf(Perl_debug_log,
- "%5lu %s\n", (unsigned long)PL_profiledata[i],
- PL_op_name[i]);
- }
-#endif /* DEBUGGING */
-}
projects / p5sagit/p5-mst-13.2.git / commitdiff