runtime runops switch

Message-ID: <20011116004809.A934@math.ohio-state.edu>

p4raw-id: //depot/perl@13044

diff --git a/dump.c b/dump.c
index 0d87fab..0ac6b0c 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -223,7 +223,7 @@ Perl_sv_peek(pTHX_ SV *sv)
        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));
     }
 
@@ -1392,3 +1392,123 @@ Perl_sv_dump(pTHX_ SV *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]);
+    }
+}

diff --git a/embed.h b/embed.h
index f8c8abb..9f4ab86 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1052,11 +1052,9 @@
 #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
@@ -2561,11 +2559,9 @@
 #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)

diff --git a/embed.pl b/embed.pl
index de6df26..dc99bdf 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2187,11 +2187,9 @@ s        |U8*    |reghopmaybe3   |U8 *pos|I32 off|U8 *lim
 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)

diff --git a/ext/Devel/Peek/Peek.pm b/ext/Devel/Peek/Peek.pm
index 16471bd..b2b0fc7 100644 (file)
--- a/ext/Devel/Peek/Peek.pm
+++ b/ext/Devel/Peek/Peek.pm
@@ -4,14 +4,14 @@
 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]);
 
@@ -23,6 +23,26 @@ sub DumpWithOP ($;$) {
    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__
 
@@ -68,6 +88,22 @@ The global variable $Devel::Peek::pv_limit can be set to limit the
 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

diff --git a/ext/Devel/Peek/Peek.xs b/ext/Devel/Peek/Peek.xs
index a2a4186..a1c2970 100644 (file)
--- a/ext/Devel/Peek/Peek.xs
+++ b/ext/Devel/Peek/Peek.xs
@@ -3,6 +3,18 @@
 #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)
 {
@@ -400,3 +412,6 @@ MODULE = Devel::Peek                PACKAGE = Devel::Peek   PREFIX = _
 SV *
 _CvGV(cv)
     SV *cv
+
+bool
+_runops_debug(int flag = -1)

diff --git a/perl.h b/perl.h
index 6fb0257..e816534 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2326,30 +2326,50 @@ Gid_t getegid (void);
 #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

diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index dba60c4..79fbc93 100644 (file)
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -1998,7 +1998,7 @@ Found in file sharedsv.c
 =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

diff --git a/pod/perlintern.pod b/pod/perlintern.pod
index 6ca016c..544b878 100644 (file)
--- a/pod/perlintern.pod
+++ b/pod/perlintern.pod
@@ -131,7 +131,7 @@ Found in file sv.c
 
 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)

diff --git a/proto.h b/proto.h
index 01d30a4..00ceb4a 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1169,11 +1169,9 @@ STATIC U8*       S_reghopmaybe3(pTHX_ U8 *pos, I32 off, U8 *lim);
 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)

diff --git a/run.c b/run.c
index 34dfc9b..2a204e9 100644 (file)
--- a/run.c
+++ b/run.c
@@ -28,140 +28,3 @@ Perl_runops_standard(pTHX)
     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 */
-}