refactor op.c S_bad_type_*v

-flags arg of both funcs is unused in all callers. Move the 0 to the funcs.
 flags arg is from commit ce16c625ec in 2012
-all bad_type_gv calls are right before the end of the switch, the pushing
 of 1st 3 args and call asm ops can be merged together, leaving the 1
 string constant push as the only unique op between the 7 src code
 callers of bad_type_gv, this requires reordering the args so the only
 unique one is the last/right most one, reordering can't be done to
 bad_type_pv because each following execution point after each bad_type_pv
 is different, bad_type_pv's caller/s are not a switch statement
- commit 53e06cf030 probably overlooked the 2 PL_op_desc[type] places,
  OP_DESC is a fancier superset of PL_op_desc[type], since calling
  bad_type_pv only happens during a PP syntax error, that is not
  performance critical, so replace PL_op_desc[type] with OP_DESC and
  factor out OP to description string lookup, plus custom ops are very rare
  so this shouldn't impact the error message seen by the user

VC2003 .text section of perl521.dll before 0xc9543 after 0xC9523

diff --git a/embed.fnc b/embed.fnc
index 020872c..187d113 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1938,8 +1938,8 @@ s |OP *   |my_kid         |NULLOK OP *o|NULLOK OP *attrs|NN OP **imopsp
 s      |OP *   |dup_attrlist   |NN OP *o
 s      |void   |apply_attrs    |NN HV *stash|NN SV *target|NULLOK OP *attrs
 s      |void   |apply_attrs_my |NN HV *stash|NN OP *target|NULLOK OP *attrs|NN OP **imopsp
 s      |OP *   |dup_attrlist   |NN OP *o
 s      |void   |apply_attrs    |NN HV *stash|NN SV *target|NULLOK OP *attrs
 s      |void   |apply_attrs_my |NN HV *stash|NN OP *target|NULLOK OP *attrs|NN OP **imopsp

-s      |void   |bad_type_pv    |I32 n|NN const char *t|NN const char *name|U32 flags|NN const OP *kid
-s      |void   |bad_type_gv    |I32 n|NN const char *t|NN GV *gv|U32 flags|NN const OP *kid
+s      |void   |bad_type_pv    |I32 n|NN const char *t|NN const OP *o|NN const OP *kid
+s      |void   |bad_type_gv    |I32 n|NN GV *gv|NN const OP *kid|NN const char *t

 s      |void   |no_bareword_allowed|NN OP *o
 sR     |OP*    |no_fh_allowed|NN OP *o
 sR     |OP*    |too_few_arguments_pv|NN OP *o|NN const char* name|U32 flags
 s      |void   |no_bareword_allowed|NN OP *o
 sR     |OP*    |no_fh_allowed|NN OP *o
 sR     |OP*    |too_few_arguments_pv|NN OP *o|NN const char* name|U32 flags

diff --git a/embed.h b/embed.h
index c484be0..70cab3e 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1518,8 +1518,8 @@
 #define apply_attrs(a,b,c)     S_apply_attrs(aTHX_ a,b,c)
 #define apply_attrs_my(a,b,c,d)        S_apply_attrs_my(aTHX_ a,b,c,d)
 #define assignment_type(a)     S_assignment_type(aTHX_ a)
 #define apply_attrs(a,b,c)     S_apply_attrs(aTHX_ a,b,c)
 #define apply_attrs_my(a,b,c,d)        S_apply_attrs_my(aTHX_ a,b,c,d)
 #define assignment_type(a)     S_assignment_type(aTHX_ a)

-#define bad_type_gv(a,b,c,d,e) S_bad_type_gv(aTHX_ a,b,c,d,e)
-#define bad_type_pv(a,b,c,d,e) S_bad_type_pv(aTHX_ a,b,c,d,e)
+#define bad_type_gv(a,b,c,d)   S_bad_type_gv(aTHX_ a,b,c,d)
+#define bad_type_pv(a,b,c,d)   S_bad_type_pv(aTHX_ a,b,c,d)

 #define clear_special_blocks(a,b,c)    S_clear_special_blocks(aTHX_ a,b,c)
 #define cop_free(a)            S_cop_free(aTHX_ a)
 #define dup_attrlist(a)                S_dup_attrlist(aTHX_ a)
 #define clear_special_blocks(a,b,c)    S_clear_special_blocks(aTHX_ a,b,c)
 #define cop_free(a)            S_cop_free(aTHX_ a)
 #define dup_attrlist(a)                S_dup_attrlist(aTHX_ a)

diff --git a/op.c b/op.c
index 28cca42..637a60e 100644 (file)
--- a/op.c
+++ b/op.c
@@ -541,22 +541,24 @@ S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 }
 
 STATIC void
 }
 
 STATIC void

-S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
+S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)

 {
     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 
     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 {
     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 
     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",

-                (int)n, name, t, OP_DESC(kid)), flags);
+                (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);

 }
 
 }
 

+/* remove flags var, its unused in all callers, move to to right end since gv
+  and kid are always the same */

 STATIC void
 STATIC void

-S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
+S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)

 {
     SV * const namesv = cv_name((CV *)gv, NULL, 0);
     PERL_ARGS_ASSERT_BAD_TYPE_GV;
  
     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 {
     SV * const namesv = cv_name((CV *)gv, NULL, 0);
     PERL_ARGS_ASSERT_BAD_TYPE_GV;
  
     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",

-                (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
+                (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));

 }
 
 STATIC void
 }
 
 STATIC void


@@ -9969,7 +9971,7 @@ Perl_ck_fun(pTHX_ OP *o)
                      && (  !SvROK(cSVOPx_sv(kid)) 
                         || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
                        )
                      && (  !SvROK(cSVOPx_sv(kid)) 
                         || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
                        )

-                   bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
+                   bad_type_pv(numargs, "array", o, kid);

                /* Defer checks to run-time if we have a scalar arg */
                if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
                    op_lvalue(kid, type);
                /* Defer checks to run-time if we have a scalar arg */
                if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
                    op_lvalue(kid, type);


@@ -9984,7 +9986,7 @@ Perl_ck_fun(pTHX_ OP *o)
                break;
            case OA_HVREF:
                if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
                break;
            case OA_HVREF:
                if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)

-                   bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
+                   bad_type_pv(numargs, "hash", o, kid);

                op_lvalue(kid, type);
                break;
            case OA_CVREF:
                op_lvalue(kid, type);
                break;
            case OA_CVREF:


@@ -10010,7 +10012,7 @@ Perl_ck_fun(pTHX_ OP *o)
                    }
                    else if (kid->op_type == OP_READLINE) {
                        /* neophyte patrol: open(<FH>), close(<FH>) etc. */
                    }
                    else if (kid->op_type == OP_READLINE) {
                        /* neophyte patrol: open(<FH>), close(<FH>) etc. */

-                       bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
+                       bad_type_pv(numargs, "HANDLE", o, kid);

                    }
                    else {
                        I32 flags = OPf_SPECIAL;
                    }
                    else {
                        I32 flags = OPf_SPECIAL;


@@ -11417,9 +11419,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                        != OP_ANONCODE
                    && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
                        != OP_RV2CV))
                        != OP_ANONCODE
                    && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
                        != OP_RV2CV))

-                   bad_type_gv(arg,
-                           arg == 1 ? "block or sub {}" : "sub {}",
-                           namegv, 0, o3);
+                   bad_type_gv(arg, namegv, o3,
+                           arg == 1 ? "block or sub {}" : "sub {}");

                break;
            case '*':
                /* '*' allows any scalar type, including bareword */
                break;
            case '*':
                /* '*' allows any scalar type, including bareword */


@@ -11474,9 +11475,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                                     OP_READ, /* not entersub */
                                     OP_LVALUE_NO_CROAK
                                    )) goto wrapref;
                                     OP_READ, /* not entersub */
                                     OP_LVALUE_NO_CROAK
                                    )) goto wrapref;

-                           bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
-                                       (int)(end - p), p),
-                                   namegv, 0, o3);
+                           bad_type_gv(arg, namegv, o3,
+                                   Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));

                        } else
                            goto oops;
                        break;
                        } else
                            goto oops;
                        break;


@@ -11484,15 +11484,14 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                        if (o3->op_type == OP_RV2GV)
                            goto wrapref;
                        if (!contextclass)
                        if (o3->op_type == OP_RV2GV)
                            goto wrapref;
                        if (!contextclass)

-                           bad_type_gv(arg, "symbol", namegv, 0, o3);
+                           bad_type_gv(arg, namegv, o3, "symbol");

                        break;
                    case '&':
                        if (o3->op_type == OP_ENTERSUB
                         && !(o3->op_flags & OPf_STACKED))
                            goto wrapref;
                        if (!contextclass)
                        break;
                    case '&':
                        if (o3->op_type == OP_ENTERSUB
                         && !(o3->op_flags & OPf_STACKED))
                            goto wrapref;
                        if (!contextclass)

-                           bad_type_gv(arg, "subroutine", namegv, 0,
-                                   o3);
+                           bad_type_gv(arg, namegv, o3, "subroutine");

                        break;
                    case '$':
                        if (o3->op_type == OP_RV2SV ||
                        break;
                    case '$':
                        if (o3->op_type == OP_RV2SV ||


@@ -11507,7 +11506,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                                    OP_READ,  /* not entersub */
                                    OP_LVALUE_NO_CROAK
                               )) goto wrapref;
                                    OP_READ,  /* not entersub */
                                    OP_LVALUE_NO_CROAK
                               )) goto wrapref;

-                           bad_type_gv(arg, "scalar", namegv, 0, o3);
+                           bad_type_gv(arg, namegv, o3, "scalar");

                        }
                        break;
                    case '@':
                        }
                        break;
                    case '@':


@@ -11518,7 +11517,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                            goto wrapref;
                        }
                        if (!contextclass)
                            goto wrapref;
                        }
                        if (!contextclass)

-                           bad_type_gv(arg, "array", namegv, 0, o3);
+                           bad_type_gv(arg, namegv, o3, "array");

                        break;
                    case '%':
                        if (o3->op_type == OP_RV2HV ||
                        break;
                    case '%':
                        if (o3->op_type == OP_RV2HV ||


@@ -11528,7 +11527,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                            goto wrapref;
                        }
                        if (!contextclass)
                            goto wrapref;
                        }
                        if (!contextclass)

-                           bad_type_gv(arg, "hash", namegv, 0, o3);
+                           bad_type_gv(arg, namegv, o3, "hash");

                        break;
                    wrapref:
                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
                        break;
                    wrapref:
                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,

diff --git a/proto.h b/proto.h
index b72c283..58724ac 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6305,19 +6305,19 @@ STATIC void     S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp
 STATIC I32     S_assignment_type(pTHX_ const OP *o)
                        __attribute__warn_unused_result__;
 
 STATIC I32     S_assignment_type(pTHX_ const OP *o)
                        __attribute__warn_unused_result__;
 

-STATIC void    S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
+STATIC void    S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)

                        __attribute__nonnull__(pTHX_2)
                        __attribute__nonnull__(pTHX_3)
                        __attribute__nonnull__(pTHX_2)
                        __attribute__nonnull__(pTHX_3)

-                       __attribute__nonnull__(pTHX_5);
+                       __attribute__nonnull__(pTHX_4);

 #define PERL_ARGS_ASSERT_BAD_TYPE_GV   \
 #define PERL_ARGS_ASSERT_BAD_TYPE_GV   \

-       assert(t); assert(gv); assert(kid)
+       assert(gv); assert(kid); assert(t)

 
 

-STATIC void    S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
+STATIC void    S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)

                        __attribute__nonnull__(pTHX_2)
                        __attribute__nonnull__(pTHX_3)
                        __attribute__nonnull__(pTHX_2)
                        __attribute__nonnull__(pTHX_3)

-                       __attribute__nonnull__(pTHX_5);
+                       __attribute__nonnull__(pTHX_4);

 #define PERL_ARGS_ASSERT_BAD_TYPE_PV   \
 #define PERL_ARGS_ASSERT_BAD_TYPE_PV   \

-       assert(t); assert(name); assert(kid)
+       assert(t); assert(o); assert(kid)

 
 STATIC void    S_clear_special_blocks(pTHX_ const char *const fullname, GV *const gv, CV *const cv)
                        __attribute__nonnull__(pTHX_1)
 
 STATIC void    S_clear_special_blocks(pTHX_ const char *const fullname, GV *const gv, CV *const cv)
                        __attribute__nonnull__(pTHX_1)