From: David Mitchell Date: Thu, 20 Aug 2009 18:29:35 +0000 (+0100) Subject: add -DM flag to track smartmatch resolution X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d7c0d2821cad1d2e5b6b3d6440e7c22bfaae9559;p=p5sagit%2Fp5-mst-13.2.git add -DM flag to track smartmatch resolution --- diff --git a/perl.c b/perl.c index 9ef9cd7..6c1b543 100644 --- a/perl.c +++ b/perl.c @@ -2863,6 +2863,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " C Copy On Write", " A Consistency checks on internal structures", " q quiet - currently only suppresses the 'EXECUTING' message", + " M trace smart match resolution", NULL }; int i = 0; @@ -2871,7 +2872,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) if (isALPHA(**s)) { /* if adding extra options, remember to update DEBUG_MASK */ - static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq"; + static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqM"; for (; isALNUM(**s); (*s)++) { const char * const d = strchr(debopts,**s); diff --git a/perl.h b/perl.h index 6fafe9a..75c52e7 100644 --- a/perl.h +++ b/perl.h @@ -3619,7 +3619,8 @@ Gid_t getegid (void); #define DEBUG_C_FLAG 0x00200000 /*2097152 */ #define DEBUG_A_FLAG 0x00400000 /*4194304 */ #define DEBUG_q_FLAG 0x00800000 /*8388608 */ -#define DEBUG_MASK 0x00FEEFFF /* mask of all the standard flags */ +#define DEBUG_M_FLAG 0x01000000 /*8388608 */ +#define DEBUG_MASK 0x01FEEFFF /* mask of all the standard flags */ #define DEBUG_DB_RECURSE_FLAG 0x40000000 #define DEBUG_TOP_FLAG 0x80000000 /* XXX what's this for ??? Signal @@ -3648,6 +3649,7 @@ Gid_t getegid (void); # define DEBUG_C_TEST_ (PL_debug & DEBUG_C_FLAG) # define DEBUG_A_TEST_ (PL_debug & DEBUG_A_FLAG) # define DEBUG_q_TEST_ (PL_debug & DEBUG_q_FLAG) +# define DEBUG_M_TEST_ (PL_debug & DEBUG_M_FLAG) # define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_) # define DEBUG_Uv_TEST_ (DEBUG_U_TEST_ && DEBUG_v_TEST_) @@ -3676,6 +3678,7 @@ Gid_t getegid (void); # define DEBUG_C_TEST DEBUG_C_TEST_ # define DEBUG_A_TEST DEBUG_A_TEST_ # define DEBUG_q_TEST DEBUG_q_TEST_ +# define DEBUG_M_TEST DEBUG_M_TEST_ # define DEBUG_Xv_TEST DEBUG_Xv_TEST_ # define DEBUG_Uv_TEST DEBUG_Uv_TEST_ @@ -3722,6 +3725,7 @@ Gid_t getegid (void); # define DEBUG_C(a) DEBUG__(DEBUG_C_TEST, a) # define DEBUG_A(a) DEBUG__(DEBUG_A_TEST, a) # define DEBUG_q(a) DEBUG__(DEBUG_q_TEST, a) +# define DEBUG_M(a) DEBUG__(DEBUG_M_TEST, a) #else /* DEBUGGING */ @@ -3748,6 +3752,7 @@ Gid_t getegid (void); # define DEBUG_C_TEST (0) # define DEBUG_A_TEST (0) # define DEBUG_q_TEST (0) +# define DEBUG_M_TEST (0) # define DEBUG_Xv_TEST (0) # define DEBUG_Uv_TEST (0) @@ -3775,6 +3780,7 @@ Gid_t getegid (void); # define DEBUG_C(a) # define DEBUG_A(a) # define DEBUG_q(a) +# define DEBUG_M(a) # define DEBUG_Xv(a) # define DEBUG_Uv(a) #endif /* DEBUGGING */ diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 994aecb..3d177eb 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -417,6 +417,7 @@ B<-D14> is equivalent to B<-Dtls>): 2097152 C Copy On Write 4194304 A Consistency checks on internal structures 8388608 q quiet - currently only suppresses the "EXECUTING" message + 16777216 M trace smart match resolution All these flags require B<-DDEBUGGING> when you compile the Perl executable (but see L, L which may change this). diff --git a/pp_ctl.c b/pp_ctl.c index 453d6d7..35e3436 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3990,6 +3990,7 @@ S_destroy_matcher(pTHX_ PMOP *matcher) /* Do a smart match */ PP(pp_smartmatch) { + DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n")); return do_smartmatch(NULL, NULL); } @@ -4008,13 +4009,18 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) /* First of all, handle overload magic of the rightmost argument */ if (SvAMAGIC(e)) { - SV * const tmpsv = amagic_call(d, e, smart_amg, 0); + SV * tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); + + tmpsv = amagic_call(d, e, smart_amg, 0); if (tmpsv) { SPAGAIN; (void)POPs; SETs(tmpsv); RETURN; } + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n")); } SP -= 2; /* Pop the values */ @@ -4034,14 +4040,17 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) /* ~~ undef */ if (!SvOK(e)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); if (SvOK(d)) RETPUSHNO; else RETPUSHYES; } - if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) + if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); + } if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) object_on_left = TRUE; @@ -4057,9 +4066,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) bool andedresults = TRUE; HV *hv = (HV*) SvRV(d); I32 numkeys = hv_iterinit(hv); + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n")); if (numkeys == 0) RETPUSHYES; while ( (he = hv_iternext(hv)) ) { + DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); ENTER; SAVETMPS; PUSHMARK(SP); @@ -4085,10 +4096,12 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) bool andedresults = TRUE; AV *av = (AV*) SvRV(d); const I32 len = av_len(av); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); if (len == -1) RETPUSHYES; for (i = 0; i <= len; ++i) { SV * const * const svp = av_fetch(av, i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); ENTER; SAVETMPS; PUSHMARK(SP); @@ -4111,6 +4124,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } else { sm_any_sub: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); ENTER; SAVETMPS; PUSHMARK(SP); @@ -4133,6 +4147,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) goto sm_any_hash; /* Treat objects like scalars */ } else if (!SvOK(d)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n")); RETPUSHNO; } else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { @@ -4144,7 +4159,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) U32 this_key_count = 0, other_key_count = 0; HV *hv = MUTABLE_HV(SvRV(e)); - + + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); /* Tied hashes don't know how many keys they have. */ if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { tied = TRUE; @@ -4166,7 +4182,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) (void) hv_iterinit(hv); while ( (he = hv_iternext(hv)) ) { SV *key = hv_iterkeysv(he); - + + DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n")); ++ this_key_count; if(!hv_exists_ent(other_hv, key, 0)) { @@ -4194,8 +4211,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) I32 i; HV *hv = MUTABLE_HV(SvRV(e)); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); for (i = 0; i < other_len; ++i) { SV ** const svp = av_fetch(other_av, i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); if (svp) { /* ??? When can this not happen? */ if (hv_exists_ent(hv, *svp, 0)) RETPUSHYES; @@ -4204,6 +4223,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHNO; } else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n")); sm_regex_hash: { PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); @@ -4212,6 +4232,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) (void) hv_iterinit(hv); while ( (he = hv_iternext(hv)) ) { + DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { (void) hv_iterinit(hv); destroy_matcher(matcher); @@ -4224,6 +4245,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } else { sm_any_hash: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n")); if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0)) RETPUSHYES; else @@ -4240,8 +4262,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) const I32 other_len = av_len(other_av) + 1; I32 i; + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); for (i = 0; i < other_len; ++i) { SV ** const svp = av_fetch(other_av, i, FALSE); + + DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n")); if (svp) { /* ??? When can this not happen? */ if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0)) RETPUSHYES; @@ -4251,6 +4276,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { AV *other_av = MUTABLE_AV(SvRV(d)); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av)) RETPUSHNO; else { @@ -4292,8 +4318,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) PUSHs(*this_elem); PUTBACK; + DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); (void) do_smartmatch(seen_this, seen_other); SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); if (!SvTRUEx(POPs)) RETPUSHNO; @@ -4303,6 +4331,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } } else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n")); sm_regex_array: { PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); @@ -4311,6 +4340,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) for(i = 0; i <= this_len; ++i) { SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); if (svp && matcher_matches_sv(matcher, *svp)) { destroy_matcher(matcher); RETPUSHYES; @@ -4325,8 +4355,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); I32 i; + DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); for (i = 0; i <= this_len; ++i) { SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n")); if (!svp || !SvOK(*svp)) RETPUSHYES; } @@ -4338,6 +4370,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) I32 i; const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); for (i = 0; i <= this_len; ++i) { SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); if (!svp) @@ -4347,8 +4380,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) PUSHs(*svp); PUTBACK; /* infinite recursion isn't supposed to happen here */ + DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); (void) do_smartmatch(NULL, NULL); SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); if (SvTRUEx(POPs)) RETPUSHYES; } @@ -4360,15 +4395,18 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) { if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { SV *t = d; d = e; e = t; + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n")); goto sm_regex_hash; } else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { SV *t = d; d = e; e = t; + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n")); goto sm_regex_array; } else { PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); PUTBACK; PUSHs(matcher_matches_sv(matcher, d) ? &PL_sv_yes @@ -4381,6 +4419,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) /* See if there is overload magic on left */ else if (object_on_left && SvAMAGIC(d)) { SV *tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); PUSHs(d); PUSHs(e); PUTBACK; tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); @@ -4391,15 +4431,22 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETURN; } SP -= 2; + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); goto sm_any_scalar; } else if (!SvOK(d)) { /* undef ~~ scalar ; we already know that the scalar is SvOK */ + DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n")); RETPUSHNO; } else sm_any_scalar: if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) { + DEBUG_M(if (SvNIOK(e)) + Perl_deb(aTHX_ " applying rule Any-Num\n"); + else + Perl_deb(aTHX_ " applying rule Num-numish\n"); + ); /* numeric comparison */ PUSHs(d); PUSHs(e); PUTBACK; @@ -4415,6 +4462,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } /* As a last resort, use string comparison */ + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n")); PUSHs(d); PUSHs(e); PUTBACK; return pp_seq();