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.
# 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
#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)
use warnings;
use Carp;
-our $VERSION = '0.56';
+our $VERSION = '0.57';
require XSLoader;
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;
use warnings;
use strict;
-use Test::More tests => 23;
+use Test::More tests => 24;
use XS::APItest;
my $ppaddr = xop_ppaddr;
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);
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 *
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;
=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;
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,
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;
+ }
}
/*
=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.
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
#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
#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 { \
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
*/
#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))
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 */
/* 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.
union any {
void* any_ptr;
I32 any_i32;
+ U32 any_u32;
IV any_iv;
UV any_uv;
long any_long;
#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);
#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);
projects / platform / upstream / perl.git / commitdiff