Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

add wrap_op_checker() API function

This function provides a convenient and thread-safe way for modules to
hook op checking.
  • Loading branch information...
commit e8570548af49b057631f1011e4b19c8c4a1342dd 1 parent 96a6e6f
Zefram authored
View
1  MANIFEST
@@ -3944,6 +3944,7 @@ ext/XS-APItest/MANIFEST XS::APItest extension
ext/XS-APItest/notcore.c Test API functions when PERL_CORE is not defined
ext/XS-APItest/numeric.xs XS::APItest wrappers for numeric.c
ext/XS-APItest/README XS::APItest extension
+ext/XS-APItest/t/addissub.t test op check wrapping
ext/XS-APItest/t/arrayexpr.t test recursive descent expression parsing
ext/XS-APItest/t/autoload.t Test XS AUTOLOAD routines
ext/XS-APItest/t/BHK.pm Helper for ./blockhooks.t
View
4 dosish.h
@@ -52,7 +52,9 @@
#endif /* DJGPP */
#ifndef PERL_SYS_TERM_BODY
-# define PERL_SYS_TERM_BODY() HINTS_REFCNT_TERM; OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM
+# define PERL_SYS_TERM_BODY() \
+ HINTS_REFCNT_TERM; OP_CHECK_MUTEX_TERM; \
+ OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM
#endif
#define dXSUB_SYS
View
1  embed.fnc
@@ -937,6 +937,7 @@ po |OP* |ck_entersub_args_core|NN OP *entersubop|NN GV *namegv \
|NN SV *protosv
Apd |void |cv_get_call_checker|NN CV *cv|NN Perl_call_checker *ckfun_p|NN SV **ckobj_p
Apd |void |cv_set_call_checker|NN CV *cv|NN Perl_call_checker ckfun|NN SV *ckobj
+Apd |void |wrap_op_checker|Optype opcode|NN Perl_check_t new_checker|NN Perl_check_t *old_checker_p
Apa |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems
Ap |char* |scan_vstring |NN const char *s|NN const char *const e \
|NN SV *sv
View
1  embed.h
@@ -698,6 +698,7 @@
#define whichsig_pv(a) Perl_whichsig_pv(aTHX_ a)
#define whichsig_pvn(a,b) Perl_whichsig_pvn(aTHX_ a,b)
#define whichsig_sv(a) Perl_whichsig_sv(aTHX_ a)
+#define wrap_op_checker(a,b,c) Perl_wrap_op_checker(aTHX_ a,b,c)
#if !(defined(HAS_SIGACTION) && defined(SA_SIGINFO))
#define csighandler Perl_csighandler
#endif
View
2  embedvar.h
@@ -403,6 +403,8 @@
#define PL_Gappctx (my_vars->Gappctx)
#define PL_check (my_vars->Gcheck)
#define PL_Gcheck (my_vars->Gcheck)
+#define PL_check_mutex (my_vars->Gcheck_mutex)
+#define PL_Gcheck_mutex (my_vars->Gcheck_mutex)
#define PL_csighandlerp (my_vars->Gcsighandlerp)
#define PL_Gcsighandlerp (my_vars->Gcsighandlerp)
#define PL_curinterp (my_vars->Gcurinterp)
View
23 ext/XS-APItest/APItest.xs
@@ -1079,6 +1079,25 @@ XS_EXTERNAL(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
static struct mro_alg mymro;
+static Perl_check_t addissub_nxck_add;
+
+static OP *
+addissub_myck_add(pTHX_ OP *op)
+{
+ SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addissub", 0);
+ OP *aop, *bop;
+ U8 flags;
+ if (!(flag_svp && SvTRUE(*flag_svp) && (op->op_flags & OPf_KIDS) &&
+ (aop = cBINOPx(op)->op_first) && (bop = aop->op_sibling) &&
+ !bop->op_sibling))
+ return addissub_nxck_add(aTHX_ op);
+ aop->op_sibling = NULL;
+ cBINOPx(op)->op_first = NULL;
+ op->op_flags &= ~OPf_KIDS;
+ flags = op->op_flags;
+ op_free(op);
+ return newBINOP(OP_SUBTRACT, flags, aop, bop);
+}
#include "const-c.inc"
@@ -3287,6 +3306,10 @@ CODE:
OUTPUT:
RETVAL
+void
+setup_addissub()
+CODE:
+ wrap_op_checker(OP_ADD, addissub_myck_add, &addissub_nxck_add);
MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
View
19 ext/XS-APItest/t/addissub.t
@@ -0,0 +1,19 @@
+use warnings;
+use strict;
+
+use Test::More tests => 9;
+use XS::APItest ();
+
+alarm 10; # likely failure mode is an infinite loop
+
+ok 1;
+is eval q{ 3 + 1 }, 4;
+is eval q{ BEGIN { $^H{"XS::APItest/addissub"} = 1; } 3 + 1 }, 4;
+XS::APItest::setup_addissub(); ok 1;
+is eval q{ 3 + 1 }, 4;
+is eval q{ BEGIN { $^H{"XS::APItest/addissub"} = 1; } 3 + 1 }, 2;
+XS::APItest::setup_addissub(); ok 1;
+is eval q{ 3 + 1 }, 4;
+is eval q{ BEGIN { $^H{"XS::APItest/addissub"} = 1; } 3 + 1 }, 2;
+
+1;
View
63 op.c
@@ -10677,6 +10677,69 @@ Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
name);
}
+/*
+=head1 Hook manipulation
+
+These functions provide convenient and thread-safe means of manipulating
+hook variables.
+
+=cut
+*/
+
+/*
+=for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
+
+Puts a C function into the chain of check functions for a specified op
+type. This is the preferred way to manipulate the L</PL_check> array.
+I<opcode> specifies which type of op is to be affected. I<new_checker>
+is a pointer to the C function that is to be added to that opcode's
+check chain, and I<old_checker_p> points to the storage location where a
+pointer to the next function in the chain will be stored. The value of
+I<new_pointer> is written into the L</PL_check> array, while the value
+previously stored there is written to I<*old_checker_p>.
+
+L</PL_check> is global to an entire process, and a module wishing to
+hook op checking may find itself invoked more than once per process,
+typically in different threads. To handle that situation, this function
+is idempotent. The location I<*old_checker_p> must initially (once
+per process) contain a null pointer. A C variable of static duration
+(declared at file scope, typically also marked C<static> to give
+it internal linkage) will be implicitly initialised appropriately,
+if it does not have an explicit initialiser. This function will only
+actually modify the check chain if it finds I<*old_checker_p> to be null.
+This function is also thread safe on the small scale. It uses appropriate
+locking to avoid race conditions in accessing L</PL_check>.
+
+When this function is called, the function referenced by I<new_checker>
+must be ready to be called, except for I<*old_checker_p> being unfilled.
+In a threading situation, I<new_checker> may be called immediately,
+even before this function has returned. I<*old_checker_p> will always
+be appropriately set before I<new_checker> is called. If I<new_checker>
+decides not to do anything special with an op that it is given (which
+is the usual case for most uses of op check hooking), it must chain the
+check function referenced by I<*old_checker_p>.
+
+If you want to influence compilation of calls to a specific subroutine,
+then use L</cv_set_call_checker> rather than hooking checking of all
+C<entersub> ops.
+
+=cut
+*/
+
+void
+Perl_wrap_op_checker(pTHX_ Optype opcode,
+ Perl_check_t new_checker, Perl_check_t *old_checker_p)
+{
+ PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
+ if (*old_checker_p) return;
+ OP_CHECK_MUTEX_LOCK;
+ if (!*old_checker_p) {
+ *old_checker_p = PL_check[opcode];
+ PL_check[opcode] = new_checker;
+ }
+ OP_CHECK_MUTEX_UNLOCK;
+}
+
#include "XSUB.h"
/* Efficient sub that returns a constant scalar value. */
View
16 op.h
@@ -1000,6 +1000,22 @@ struct token {
*/
/*
+=head1 Hook manipulation
+*/
+
+#ifdef USE_ITHREADS
+# define OP_CHECK_MUTEX_INIT MUTEX_INIT(&PL_check_mutex)
+# define OP_CHECK_MUTEX_LOCK MUTEX_LOCK(&PL_check_mutex)
+# define OP_CHECK_MUTEX_UNLOCK MUTEX_UNLOCK(&PL_check_mutex)
+# define OP_CHECK_MUTEX_TERM MUTEX_DESTROY(&PL_check_mutex)
+#else
+# define OP_CHECK_MUTEX_INIT NOOP
+# define OP_CHECK_MUTEX_LOCK NOOP
+# define OP_CHECK_MUTEX_UNLOCK NOOP
+# define OP_CHECK_MUTEX_TERM NOOP
+#endif
+
+/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
View
1  perl.c
@@ -105,6 +105,7 @@ S_init_tls_and_interp(PerlInterpreter *my_perl)
ALLOC_THREAD_KEY;
PERL_SET_THX(my_perl);
OP_REFCNT_INIT;
+ OP_CHECK_MUTEX_INIT;
HINTS_REFCNT_INIT;
MUTEX_INIT(&PL_dollarzero_mutex);
MUTEX_INIT(&PL_my_ctx_mutex);
View
2  perlapi.h
@@ -103,6 +103,8 @@ END_EXTERN_C
#define PL_appctx (*Perl_Gappctx_ptr(NULL))
#undef PL_check
#define PL_check (*Perl_Gcheck_ptr(NULL))
+#undef PL_check_mutex
+#define PL_check_mutex (*Perl_Gcheck_mutex_ptr(NULL))
#undef PL_csighandlerp
#define PL_csighandlerp (*Perl_Gcsighandlerp_ptr(NULL))
#undef PL_curinterp
View
40 perlvars.h
@@ -10,6 +10,11 @@
/*
=head1 Global Variables
+
+These variables are global to an entire process. They are shared between
+all interpreters and all threads in a process.
+
+=cut
*/
/* Don't forget to re-run regen/embed.pl to propagate changes! */
@@ -95,6 +100,41 @@ PERLVAR(G, hints_mutex, perl_mutex) /* Mutex for refcounted he refcounting */
PERLVAR(G, watch_pvx, char *)
#endif
+/*
+=for apidoc AmU|Perl_check_t *|PL_check
+
+Array, indexed by opcode, of functions that will be called for the "check"
+phase of optree building during compilation of Perl code. For most (but
+not all) types of op, once the op has been initially built and populated
+with child ops it will be filtered through the check function referenced
+by the appropriate element of this array. The new op is passed in as the
+sole argument to the check function, and the check function returns the
+completed op. The check function may (as the name suggests) check the op
+for validity and signal errors. It may also initialise or modify parts of
+the ops, or perform more radical surgery such as adding or removing child
+ops, or even throw the op away and return a different op in its place.
+
+This array of function pointers is a convenient place to hook into the
+compilation process. An XS module can put its own custom check function
+in place of any of the standard ones, to influence the compilation of a
+particular type of op. However, a custom check function must never fully
+replace a standard check function (or even a custom check function from
+another module). A module modifying checking must instead B<wrap> the
+preexisting check function. A custom check function must be selective
+about when to apply its custom behaviour. In the usual case where
+it decides not to do anything special with an op, it must chain the
+preexisting op function. Check functions are thus linked in a chain,
+with the core's base checker at the end.
+
+For thread safety, modules should not write directly to this array.
+Instead, use the function L</wrap_op_checker>.
+
+=cut
+*/
+
+#if defined(USE_ITHREADS)
+PERLVAR(G, check_mutex, perl_mutex) /* Mutex for PL_check */
+#endif
#ifdef PERL_GLOBAL_STRUCT
PERLVAR(G, ppaddr, Perl_ppaddr_t *) /* or opcode.h */
PERLVAR(G, check, Perl_check_t *) /* or opcode.h */
View
6 proto.h
@@ -4711,6 +4711,12 @@ PERL_CALLCONV I32 Perl_whichsig_sv(pTHX_ SV* sigsv)
#define PERL_ARGS_ASSERT_WHICHSIG_SV \
assert(sigsv)
+PERL_CALLCONV void Perl_wrap_op_checker(pTHX_ Optype opcode, Perl_check_t new_checker, Perl_check_t *old_checker_p)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_WRAP_OP_CHECKER \
+ assert(new_checker); assert(old_checker_p)
+
PERL_CALLCONV void Perl_write_to_stderr(pTHX_ SV* msv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_WRITE_TO_STDERR \
View
3  unixish.h
@@ -133,7 +133,8 @@
#ifndef PERL_SYS_TERM_BODY
# define PERL_SYS_TERM_BODY() \
- HINTS_REFCNT_TERM; OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM;
+ HINTS_REFCNT_TERM; OP_CHECK_MUTEX_TERM; \
+ OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM;
#endif
Please sign in to comment.
Something went wrong with that request. Please try again.