runtime runops switch

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

p4raw-id: //depot/perl@13044

10 files changed, 219 insertions, 173 deletions

diff --git a/dump.c b/dump.c
index 0d87fab069..0ac6b0ce1d 100644
--- 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 f8c8abb061..9f4ab864ca 100644
--- 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 de6df26974..dc99bdfab4 100755
--- 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 16471bd519..b2b0fc7122 100644
--- 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 a2a4186ab8..a1c297071a 100644
--- 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 6fb0257e42..e816534fd5 100644
--- 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 dba60c4f66..79fbc932a2 100644
--- 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 6ca016cfcc..544b87887f 100644
--- 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 01d30a49ce..00ceb4a55f 100644
--- 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 34dfc9b370..2a204e9412 100644
--- 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 */
-}