This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix multi-eval of Perl_custom_op_xop in XopENTRY
authorDaniel Dragan <bulk88@hotmail.com>
Fri, 8 Nov 2013 02:33:57 +0000 (21:33 -0500)
committerFather Chrysostomos <sprout@cpan.org>
Sun, 10 Nov 2013 19:00:09 +0000 (11:00 -0800)
Commit 1830b3d9c8 introduced a flaw where XopENTRY calls
Perl_custom_op_xop twice to retrieve the same XOP *. This is inefficient
and causes extra machine code. Since I found no CPAN or upstream=blead
usage of Perl_custom_op_xop, and its previous docs say it isn't 100%
public, it is being converted to a macro.

Most usage of Perl_custom_op_xop is to conditionally fetch a member of the
XOP struct, which was previously implemented by XopENTRY. Move the XopENTRY
logic and picking defaults to an expanded version of Perl_custom_op_xop.
The union allows Perl_custom_op_get_field to return its result in 1
register, since the union is similar to a void * or IV, but with the
machine code overhead of casting, if any, being done in the callee
(Perl_custom_op_get_field), not the caller. Perl_custom_op_get_field can
also return the XOP * without looking inside it to implement
Perl_custom_op_xop.

XopENTRYCUSTOM is a wrapper around Perl_custom_op_get_field with
XopENTRY-like usage.

XopENTRY is used by the OP_* macros, which are heavily used (but rarely
called, since custom ops are rare) by Perl lang warnings system. The
vararg warning arguments are usually evaluted no matter if the warning
will be printed to STDERR or not. Since some people like to ignore warnings
or run no strict; and warnings branches are frequent in pp_*, it is
beneficial to make the OP_* macros smaller in machine code. The design
of Perl_custom_op_get_field supports these goals.

This commit does not pass judgement on Ben Morrow's unclear public or
private API designation of Perl_custom_op_xop, and whether
Perl_custom_op_xop should deprecated and removed from public API. It was
trivial to leave a form of Perl_custom_op_xop in the new design.

XOPe enums are identical to XOPf constants so no conversion has to be
done between the field selector parameter and the field flag to test
in machine code.

ASSUME and NOT_REACHED are being introduced. The closest to the 2
previously was "assert(0)". Perl has not used ASSUME or CC specific
versions of it before. Clang, GCC >= 4.5, and Visual C are supported. For
completeness, ARMCC's __promise was added, but Perl is not known to have
any support for ARMCC by this commiter.

This patch is part of perl #115032.

embed.fnc
embed.h
ext/XS-APItest/APItest.pm
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/customop.t
mathoms.c
op.c
op.h
perl.h
proto.h

index 14a9205..e6915f8 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1752,9 +1752,10 @@ Ap       |void   |sys_intern_dup |NN struct interp_intern* src|NN struct interp_intern*
 #  endif
 #endif
 
-AopP   |const XOP *    |custom_op_xop  |NN const OP *o
+AmopP  |const XOP *    |custom_op_xop  |NN const OP *o
 ApR    |const char *   |custom_op_name |NN const OP *o
 ApR    |const char *   |custom_op_desc |NN const OP *o
+pRX    |XOPRETANY      |custom_op_get_field    |NN const OP *o|const xop_flags_enum field
 Aop    |void   |custom_op_register     |NN Perl_ppaddr_t ppaddr \
                        |NN const XOP *xop
 
diff --git a/embed.h b/embed.h
index 9b04daf..29ce7b9 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define create_eval_scope(a)   Perl_create_eval_scope(aTHX_ a)
 #define croak_no_mem           Perl_croak_no_mem
 #define croak_popstack         Perl_croak_popstack
+#define custom_op_get_field(a,b)       Perl_custom_op_get_field(aTHX_ a,b)
 #define cv_clone_into(a,b)     Perl_cv_clone_into(aTHX_ a,b)
 #define cv_const_sv_or_av(a)   Perl_cv_const_sv_or_av(aTHX_ a)
 #define cv_forget_slab(a)      Perl_cv_forget_slab(aTHX_ a)
index 4a4e399..fdf643d 100644 (file)
@@ -5,7 +5,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '0.56';
+our $VERSION = '0.57';
 
 require XSLoader;
 
index 0e730b0..5498a4c 100644 (file)
@@ -1752,6 +1752,28 @@ xop_build_optree ()
     OUTPUT:
         RETVAL
 
+IV
+xop_from_custom_op ()
+    CODE:
+/* author note: this test doesn't imply Perl_custom_op_xop is or isn't public
+   API or that Perl_custom_op_xop is known to be used outside the core */
+        UNOP *unop;
+        XOP *xop;
+
+        NewOp(1102, unop, 1, UNOP);
+        unop->op_type       = OP_CUSTOM;
+        unop->op_ppaddr     = pp_xop;
+        unop->op_flags      = OPf_KIDS;
+        unop->op_private    = 0;
+        unop->op_first      = NULL;
+        unop->op_next       = NULL;
+
+        xop = Perl_custom_op_xop(aTHX_ (OP *)unop);
+        FreeOp(unop);
+        RETVAL = PTR2IV(xop);
+    OUTPUT:
+        RETVAL
+
 BOOT:
 {
     MY_CXT_INIT;
index f2773f2..b7cc598 100644 (file)
@@ -3,7 +3,7 @@
 use warnings;
 use strict;
 
-use Test::More tests => 23;
+use Test::More tests => 24;
 use XS::APItest;
 
 my $ppaddr = xop_ppaddr;
@@ -45,6 +45,8 @@ xop_register;
 
 is $ops->{$ppaddr}, $xop,       "XOP registered OK";
 
+is xop_from_custom_op, $xop,    "XOP lookup from OP roundtrips";
+
 $av = xop_build_optree;
 my $OA_UNOP = xop_OA_UNOP;
 my ($unop, $kid) = ("???" x 2);
index cfb0d5b..b5ae519 100644 (file)
--- a/mathoms.c
+++ b/mathoms.c
@@ -1151,14 +1151,14 @@ const char*
 Perl_custom_op_name(pTHX_ const OP* o)
 {
     PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
-    return XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_name);
+    return XopENTRYCUSTOM(o, xop_name);
 }
 
 const char*
 Perl_custom_op_desc(pTHX_ const OP* o)
 {
     PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
-    return XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_desc);
+    return XopENTRYCUSTOM(o, xop_desc);
 }
 
 CV *
diff --git a/op.c b/op.c
index e9a356e..bf7d4eb 100644 (file)
--- a/op.c
+++ b/op.c
@@ -11782,7 +11782,7 @@ Perl_rpeep(pTHX_ OP *o)
 
        case OP_CUSTOM: {
            Perl_cpeep_t cpeep = 
-               XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
+               XopENTRYCUSTOM(o, xop_peep);
            if (cpeep)
                cpeep(aTHX_ o, oldop);
            break;
@@ -11805,14 +11805,16 @@ Perl_peep(pTHX_ OP *o)
 =head1 Custom Operators
 
 =for apidoc Ao||custom_op_xop
-Return the XOP structure for a given custom op. This function should be
+Return the XOP structure for a given custom op. This macro should be
 considered internal to OP_NAME and the other access macros: use them instead.
+This macro does call a function. Prior to 5.19.6, this was implemented as a
+function.
 
 =cut
 */
 
-const XOP *
-Perl_custom_op_xop(pTHX_ const OP *o)
+XOPRETANY
+Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
 {
     SV *keysv;
     HE *he = NULL;
@@ -11820,7 +11822,7 @@ Perl_custom_op_xop(pTHX_ const OP *o)
 
     static const XOP xop_null = { 0, 0, 0, 0, 0 };
 
-    PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
+    PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
     assert(o->op_type == OP_CUSTOM);
 
     /* This is wrong. It assumes a function pointer can be cast to IV,
@@ -11852,13 +11854,59 @@ Perl_custom_op_xop(pTHX_ const OP *o)
            XopENTRY_set(xop, xop_desc, savepvn(pv, l));
        }
        Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
-       return xop;
     }
-
-    if (!he) return &xop_null;
-
-    xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
-    return xop;
+    else {
+       if (!he)
+           xop = (XOP *)&xop_null;
+       else
+           xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
+    }
+    {
+       XOPRETANY any;
+       if(field == XOPe_xop_ptr) {
+           any.xop_ptr = xop;
+       } else {
+           const U32 flags = XopFLAGS(xop);
+           if(flags & field) {
+               switch(field) {
+               case XOPe_xop_name:
+                   any.xop_name = xop->xop_name;
+                   break;
+               case XOPe_xop_desc:
+                   any.xop_desc = xop->xop_desc;
+                   break;
+               case XOPe_xop_class:
+                   any.xop_class = xop->xop_class;
+                   break;
+               case XOPe_xop_peep:
+                   any.xop_peep = xop->xop_peep;
+                   break;
+               default:
+                   NOT_REACHED;
+                   break;
+               }
+           } else {
+               switch(field) {
+               case XOPe_xop_name:
+                   any.xop_name = XOPd_xop_name;
+                   break;
+               case XOPe_xop_desc:
+                   any.xop_desc = XOPd_xop_desc;
+                   break;
+               case XOPe_xop_class:
+                   any.xop_class = XOPd_xop_class;
+                   break;
+               case XOPe_xop_peep:
+                   any.xop_peep = XOPd_xop_peep;
+                   break;
+               default:
+                   NOT_REACHED;
+                   break;
+               }
+           }
+       }
+       return any;
+    }
 }
 
 /*
diff --git a/op.h b/op.h
index 411b78a..8b8e3d2 100644 (file)
--- a/op.h
+++ b/op.h
@@ -900,12 +900,19 @@ Return the XOP's flags.
 =for apidoc Am||XopENTRY|XOP *xop|which
 Return a member of the XOP structure. I<which> is a cpp token indicating
 which entry to return. If the member is not set this will return a
-default value. The return type depends on I<which>.
+default value. The return type depends on I<which>. This macro evaluates its
+arguments more than once. If you are using C<Perl_custom_op_xop> to retreive a
+C<XOP *> from a C<OP *>, use the more efficient L</XopENTRYCUSTOM> instead.
+
+=for apidoc Am||XopENTRYCUSTOM|const OP *o|which
+Exactly like C<XopENTRY(XopENTRY(Perl_custom_op_xop(aTHX_ o), which)> but more
+efficient. The I<which> parameter is identical to L</XopENTRY>.
 
 =for apidoc Am|void|XopENTRY_set|XOP *xop|which|value
 Set a member of the XOP structure. I<which> is a cpp token indicating
 which entry to set. See L<perlguts/"Custom Operators"> for details about
-the available members and how they are used.
+the available members and how they are used. This macro evaluates its argument
+more than once.
 
 =for apidoc Am|void|XopDISABLE|XOP *xop|which
 Temporarily disable a member of the XOP, by clearing the appropriate flag.
@@ -924,6 +931,17 @@ struct custom_op {
     void         (*xop_peep)(pTHX_ OP *o, OP *oldop);
 };
 
+/* return value of Perl_custom_op_get_field, similar to void * then casting but
+   the U32 doesn't need truncation on 64 bit platforms in the caller, also
+   for easier macro writing */
+typedef union {
+    const char    *xop_name;
+    const char    *xop_desc;
+    U32                    xop_class;
+    void         (*xop_peep)(pTHX_ OP *o, OP *oldop);
+    XOP            *xop_ptr;
+} XOPRETANY;
+
 #define XopFLAGS(xop) ((xop)->xop_flags)
 
 #define XOPf_xop_name  0x01
@@ -931,6 +949,15 @@ struct custom_op {
 #define XOPf_xop_class 0x04
 #define XOPf_xop_peep  0x08
 
+/* used by Perl_custom_op_get_field for option checking */
+typedef enum {
+    XOPe_xop_ptr = 0, /* just get the XOP *, don't look inside it */
+    XOPe_xop_name = XOPf_xop_name,
+    XOPe_xop_desc = XOPf_xop_desc,
+    XOPe_xop_class = XOPf_xop_class,
+    XOPe_xop_peep = XOPf_xop_peep,
+} xop_flags_enum;
+
 #define XOPd_xop_name  PL_op_name[OP_CUSTOM]
 #define XOPd_xop_desc  PL_op_desc[OP_CUSTOM]
 #define XOPd_xop_class OA_BASEOP
@@ -945,6 +972,9 @@ struct custom_op {
 #define XopENTRY(xop, which) \
     ((XopFLAGS(xop) & XOPf_ ## which) ? (xop)->which : XOPd_ ## which)
 
+#define XopENTRYCUSTOM(o, which) \
+    (Perl_custom_op_get_field(aTHX_ o, XOPe_ ## which).which)
+
 #define XopDISABLE(xop, which) ((xop)->xop_flags &= ~XOPf_ ## which)
 #define XopENABLE(xop, which) \
     STMT_START { \
@@ -952,6 +982,9 @@ struct custom_op {
        assert(XopENTRY(xop, which)); \
     } STMT_END
 
+#define Perl_custom_op_xop(x) \
+    (Perl_custom_op_get_field(x, XOPe_xop_ptr).xop_ptr)
+
 /*
 =head1 Optree Manipulation Functions
 
@@ -974,13 +1007,13 @@ one of the OA_* constants from op.h.
 */
 
 #define OP_NAME(o) ((o)->op_type == OP_CUSTOM \
-                   ? XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_name) \
+                    ? XopENTRYCUSTOM(o, xop_name) \
                    : PL_op_name[(o)->op_type])
 #define OP_DESC(o) ((o)->op_type == OP_CUSTOM \
-                   ? XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_desc) \
+                    ? XopENTRYCUSTOM(o, xop_desc) \
                    : PL_op_desc[(o)->op_type])
 #define OP_CLASS(o) ((o)->op_type == OP_CUSTOM \
-                    ? XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_class) \
+                    ? XopENTRYCUSTOM(o, xop_class) \
                     : (PL_opargs[(o)->op_type] & OA_CLASS_MASK))
 
 #define newSUB(f, o, p, b)     Perl_newATTRSUB(aTHX_ (f), (o), (p), NULL, (b))
diff --git a/perl.h b/perl.h
index 287ded8..ba86872 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3085,9 +3085,9 @@ typedef pthread_key_t     perl_key;
    appropriate to call return.  In either case, include the lint directive.
  */
 #ifdef HASATTRIBUTE_NORETURN
-#  define NORETURN_FUNCTION_END assert(0); /* NOTREACHED */
+#  define NORETURN_FUNCTION_END NOT_REACHED; /* NOTREACHED */
 #else
-#  define NORETURN_FUNCTION_END assert(0); /* NOTREACHED */ return 0
+#  define NORETURN_FUNCTION_END NOT_REACHED; /* NOTREACHED */ return 0
 #endif
 
 /* Some OS warn on NULL format to printf */
@@ -3108,6 +3108,39 @@ typedef pthread_key_t    perl_key;
 /* placeholder */
 #endif
 
+
+#ifndef __has_builtin
+#  define __has_builtin(x) 0 /* not a clang style compiler */
+#endif
+
+/* ASSUME is like assert(), but it has a benefit in a release build. It is a
+   hint to a compiler about a statement of fact in a function call free
+   expression, which allows the compiler to generate better machine code.
+   In a debug build, ASSUME(x) is a synonym for assert(x). ASSUME(0) means
+   the control path is unreachable. In a for loop, ASSUME can be used to hint
+   that a loop will run atleast X times. ASSUME is based off MSVC's __assume
+   intrinsic function, see its documents for more details.
+*/
+
+#ifndef DEBUGGING
+#  if __has_builtin(__builtin_unreachable) \
+     || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5 || __GNUC__ > 5) /* 4.5 -> */
+#    define ASSUME(x) ((x) ? (void) 0 : __builtin_unreachable())
+#  elif defined(_MSC_VER)
+#    define ASSUME(x) __assume(x)
+#  elif defined(__ARMCC_VERSION) /* untested */
+#    define ASSUME(x) __promise(x)
+#  else
+/* a random compiler might define assert to its own special optimization token
+   so pass it through to C lib as a last resort */
+#    define ASSUME(x) assert(x)
+#  endif
+#else
+#  define ASSUME(x) assert(x)
+#endif
+
+#define NOT_REACHED ASSUME(0)
+
 /* Some unistd.h's give a prototype for pause() even though
    HAS_PAUSE ends up undefined.  This causes the #define
    below to be rejected by the compiler.  Sigh.
@@ -3156,6 +3189,7 @@ UNION_ANY_DEFINITION;
 union any {
     void*      any_ptr;
     I32                any_i32;
+    U32                any_u32;
     IV         any_iv;
     UV         any_uv;
     long       any_long;
diff --git a/proto.h b/proto.h
index 321a64f..f8e7631 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -723,6 +723,12 @@ PERL_CALLCONV const char * Perl_custom_op_desc(pTHX_ const OP *o)
 #define PERL_ARGS_ASSERT_CUSTOM_OP_DESC        \
        assert(o)
 
+PERL_CALLCONV XOPRETANY        Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD   \
+       assert(o)
+
 PERL_CALLCONV const char *     Perl_custom_op_name(pTHX_ const OP *o)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1);
@@ -735,11 +741,9 @@ PERL_CALLCONV void Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP
 #define PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER    \
        assert(ppaddr); assert(xop)
 
-PERL_CALLCONV const XOP *      Perl_custom_op_xop(pTHX_ const OP *o)
+/* PERL_CALLCONV const XOP *   Perl_custom_op_xop(pTHX_ const OP *o)
                        __attribute__pure__
-                       __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_CUSTOM_OP_XOP \
-       assert(o)
+                       __attribute__nonnull__(pTHX_1); */
 
 PERL_CALLCONV void     Perl_cv_ckproto_len_flags(pTHX_ const CV* cv, const GV* gv, const char* p, const STRLEN len, const U32 flags)
                        __attribute__nonnull__(pTHX_1);