diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | dosish.h | 4 | ||||
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | embedvar.h | 2 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 23 | ||||
| -rw-r--r-- | ext/XS-APItest/t/addissub.t | 19 | ||||
| -rw-r--r-- | op.c | 63 | ||||
| -rw-r--r-- | op.h | 16 | ||||
| -rw-r--r-- | perl.c | 1 | ||||
| -rw-r--r-- | perlapi.h | 2 | ||||
| -rw-r--r-- | perlvars.h | 40 | ||||
| -rw-r--r-- | proto.h | 6 | ||||
| -rw-r--r-- | unixish.h | 3 |
14 files changed, 180 insertions, 2 deletions
@@ -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 @@ -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 @@ -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 @@ -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 diff --git a/embedvar.h b/embedvar.h index d12de90121..0321963f35 100644 --- a/embedvar.h +++ b/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) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 2c20ec2fab..6e8689c107 100644 --- a/ext/XS-APItest/APItest.xs +++ b/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 diff --git a/ext/XS-APItest/t/addissub.t b/ext/XS-APItest/t/addissub.t new file mode 100644 index 0000000000..81ebc1d76d --- /dev/null +++ b/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; @@ -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. */ @@ -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 @@ -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); @@ -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 diff --git a/perlvars.h b/perlvars.h index b046fade05..20c3882fc8 100644 --- a/perlvars.h +++ b/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 */ @@ -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 \ @@ -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 |