diff options
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 57 | ||||
| -rw-r--r-- | ext/XS-APItest/t/peep.t | 39 | ||||
| -rw-r--r-- | op.c | 25 | ||||
| -rw-r--r-- | perl.h | 8 | ||||
| -rw-r--r-- | pod/perlguts.pod | 60 | ||||
| -rw-r--r-- | proto.h | 6 |
8 files changed, 179 insertions, 20 deletions
@@ -888,7 +888,7 @@ sd |void |pad_reset : Used in op.c pd |void |pad_swipe |PADOFFSET po|bool refadjust : FIXME -p |void |peep |NULLOK OP* o +p |void |peep |NULLOK OP* o|NN peep_next_t *next_peep : Defined in doio.c, used only in pp_hot.c dopM |PerlIO*|start_glob |NN SV *tmpglob|NN IO *io #if defined(USE_REENTRANT_API) @@ -3150,7 +3150,7 @@ #endif #ifdef PERL_CORE #define pad_swipe(a,b) Perl_pad_swipe(aTHX_ a,b) -#define peep(a) Perl_peep(aTHX_ a) +#define peep(a,b) Perl_peep(aTHX_ a,b) #endif #if defined(USE_REENTRANT_API) #define reentrant_size() Perl_reentrant_size(aTHX) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 3b90d95443..9e5ebe8ec4 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -17,6 +17,8 @@ typedef struct { AV *cscav; AV *bhkav; bool bhk_record; + peep_t orig_peep; + AV *peep_record; } my_cxt_t; START_MY_CXT @@ -327,6 +329,23 @@ blockhook_test_eval(pTHX_ OP *const o) STATIC BHK bhk_csc, bhk_test; +STATIC void +my_peep (pTHX_ OP *o, peep_next_t *next_peep) +{ + dMY_CXT; + + if (!o) + return; + + CALL_FPTR(MY_CXT.orig_peep)(aTHX_ o, next_peep); + + for (; o; o = o->op_next) { + if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) { + av_push(MY_CXT.peep_record, newSVsv(cSVOPx_sv(o))); + } + } +} + #include "const-c.inc" MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash @@ -618,9 +637,9 @@ refcounted_he_fetch(key, level=0) SvREFCNT_inc(RETVAL); OUTPUT: RETVAL - + #endif - + =pod sub TIEHASH { bless {}, $_[0] } @@ -693,25 +712,28 @@ BOOT: BhkENTRY_set(&bhk_test, eval, blockhook_test_eval); Perl_blockhook_register(aTHX_ &bhk_test); - MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER", + MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER", GV_ADDMULTI, SVt_PVAV); MY_CXT.cscav = GvAV(MY_CXT.cscgv); BhkENTRY_set(&bhk_csc, start, blockhook_csc_start); BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end); Perl_blockhook_register(aTHX_ &bhk_csc); -} + + MY_CXT.peep_record = newAV(); +} void CLONE(...) CODE: MY_CXT_CLONE; MY_CXT.sv = newSVpv("initial_clone",0); - MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER", + MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER", GV_ADDMULTI, SVt_PVAV); MY_CXT.cscav = NULL; MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI); MY_CXT.bhk_record = 0; + MY_CXT.peep_record = newAV(); void print_double(val) @@ -1090,3 +1112,28 @@ bhk_record(bool on) MY_CXT.bhk_record = on; if (on) av_clear(MY_CXT.bhkav); + +void +peep_enable () + PREINIT: + dMY_CXT; + CODE: + av_clear(MY_CXT.peep_record); + MY_CXT.orig_peep = PL_peepp; + PL_peepp = my_peep; + +AV * +peep_record () + PREINIT: + dMY_CXT; + CODE: + RETVAL = MY_CXT.peep_record; + OUTPUT: + RETVAL + +void +peep_record_clear () + PREINIT: + dMY_CXT; + CODE: + av_clear(MY_CXT.peep_record); diff --git a/ext/XS-APItest/t/peep.t b/ext/XS-APItest/t/peep.t new file mode 100644 index 0000000000..fa61dc3420 --- /dev/null +++ b/ext/XS-APItest/t/peep.t @@ -0,0 +1,39 @@ +#!perl -w + +BEGIN { + push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bXS\/APItest\b/) { + # Look, I'm using this fully-qualified variable more than once! + my $arch = $MacPerl::Architecture; + print "1..0 # Skip: XS::APItest was not built\n"; + exit 0; + } +} + +use strict; +use warnings; + +BEGIN { + require '../../t/test.pl'; + plan(6); + use_ok('XS::APItest') +}; + +my $record = XS::APItest::peep_record; + +XS::APItest::peep_enable; + +# our peep got called and remembered the string constant +eval q[my $foo = q/affe/]; +is(scalar @{ $record }, 1); +is($record->[0], 'affe'); + +XS::APItest::peep_record_clear; + +# peep got called for each root op of the branch +$::moo = $::moo = 0; +eval q[my $foo = $::moo ? q/x/ : q/y/]; +is(scalar @{ $record }, 2); +is($record->[0], 'x'); +is($record->[1], 'y'); @@ -103,7 +103,14 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #include "perl.h" #include "keywords.h" -#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) +#define CALL_A_PEEP(peep, o) CALL_FPTR((peep)->fn)(aTHX_ o, peep) + +#define CALL_PEEP(o) \ + STMT_START { \ + peep_next_t _next_peep = { PL_peepp, NULL }; \ + CALL_A_PEEP(&_next_peep, o); \ + } STMT_END + #define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o) #if defined(PL_OP_SLAB_ALLOC) @@ -8515,11 +8522,13 @@ S_is_inplace_av(pTHX_ OP *o, OP *oright) { * peep() is called */ void -Perl_peep(pTHX_ register OP *o) +Perl_peep(pTHX_ register OP *o, peep_next_t *next_peep) { dVAR; register OP* oldop = NULL; + PERL_ARGS_ASSERT_PEEP; + if (!o || o->op_opt) return; ENTER; @@ -8714,7 +8723,7 @@ Perl_peep(pTHX_ register OP *o) sop = fop->op_sibling; while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; - peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ + CALL_A_PEEP(next_peep, cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ stitch_keys: o->op_opt = 1; @@ -8765,20 +8774,20 @@ Perl_peep(pTHX_ register OP *o) case OP_ONCE: while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; - peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ + CALL_A_PEEP(next_peep, cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ break; case OP_ENTERLOOP: case OP_ENTERITER: while (cLOOP->op_redoop->op_type == OP_NULL) cLOOP->op_redoop = cLOOP->op_redoop->op_next; - peep(cLOOP->op_redoop); + CALL_A_PEEP(next_peep, cLOOP->op_redoop); while (cLOOP->op_nextop->op_type == OP_NULL) cLOOP->op_nextop = cLOOP->op_nextop->op_next; - peep(cLOOP->op_nextop); + CALL_A_PEEP(next_peep, cLOOP->op_nextop); while (cLOOP->op_lastop->op_type == OP_NULL) cLOOP->op_lastop = cLOOP->op_lastop->op_next; - peep(cLOOP->op_lastop); + CALL_A_PEEP(next_peep, cLOOP->op_lastop); break; case OP_SUBST: @@ -8787,7 +8796,7 @@ Perl_peep(pTHX_ register OP *o) cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) cPMOP->op_pmstashstartu.op_pmreplstart = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; - peep(cPMOP->op_pmstashstartu.op_pmreplstart); + CALL_A_PEEP(next_peep, cPMOP->op_pmstashstartu.op_pmreplstart); break; case OP_EXEC: @@ -4833,7 +4833,13 @@ struct perl_debug_pad { PERL_DEBUG_PAD(i)) /* Enable variables which are pointers to functions */ -typedef void (CPERLscope(*peep_t))(pTHX_ OP* o); +struct peep_next; +typedef void (CPERLscope(*peep_t))(pTHX_ OP* o, struct peep_next *next); +typedef struct peep_next { + peep_t fn; + void *user_data; +} peep_next_t; + typedef regexp*(CPERLscope(*regcomp_t)) (pTHX_ char* exp, char* xend, PMOP* pm); typedef I32 (CPERLscope(*regexec_t)) (pTHX_ regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 62e99bd386..6a244b7d79 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1821,9 +1821,63 @@ of free()ing (i.e. their type is changed to OP_NULL). After the compile tree for a subroutine (or for an C<eval> or a file) is created, an additional pass over the code is performed. This pass is neither top-down or bottom-up, but in the execution order (with -additional complications for conditionals). These optimizations are -done in the subroutine peep(). Optimizations performed at this stage -are subject to the same restrictions as in the pass 2. +additional complications for conditionals). Optimizations performed +at this stage are subject to the same restrictions as in the pass 2. + +Peephole optimizations are done by calling the function pointed to by +the global variable C<PL_peepp>. By default, C<PL_peepp> points to the +function C<Perl_peep>. However, extensions may provide their own +peephole optimizers, like this: + + peep_t original_peep; + + void my_peep (pTHX_ OP *o, peep_next_t *next_peep) + { + /* Delegate perl's original optimizer. The function pointer + * in next_peep->fn will point to the optimizer function + * initially invoked, so when perl's peep recurses into some + * branch of the optree, it'll call back to my_peep. + */ + CALL_FPTR(original_peep)(aTHX_ o, next_peep); + + if (!o) + return; + + for (; o; o = o->op_next) { + /* custom optimisations */ + } + } + + /* later, for example in a BOOT section */ + original_peep = PL_peepp; + PL_peepp = my_peep; + +Do note that the peephole optimizer is called for each root of an +optree. It has to traverse that optree itself, if necessary. + +However, it is not normally necessary for peep extensions to walk into +branches of conditions. Perl's original optimizer, which extensions should +always delegate to, already implements that and will call the optimizer +pointed to by C<next_peep> for each root OP of branches. By default, +C<next_peep> points to whatever is in C<PL_peepp>, but it is also possible +to make the default optimizer call back to different optimizers: + + void my_peep (pTHX_ OP *o, peep_next_t *next_peep) + { + peep_next_t other_peep = { my_other_peep, NULL }; + + /* call the original peep, and have it call my_other_peep when + * recursing into branches */ + CALL_FPTR(original_peep)(aTHX_ o, &other_peep); + } + +The second member of C<peep_next_t>, C<user_data>, which is just set to +C<NULL> in the above example, may be used to pass along arbitrary data to +later invocations of peep functions. + +Also note that, under some conditions, the peephole optimizer will be +called with a C<NULL> opcode. That is perfectly normal and optimizer +functions need to accomodate for that. =head2 Pluggable runops @@ -2570,7 +2570,11 @@ PERL_CALLCONV void Perl_pad_free(pTHX_ PADOFFSET po); STATIC void S_pad_reset(pTHX); #endif PERL_CALLCONV void Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust); -PERL_CALLCONV void Perl_peep(pTHX_ OP* o); +PERL_CALLCONV void Perl_peep(pTHX_ OP* o, peep_next_t *next_peep) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_PEEP \ + assert(next_peep) + PERL_CALLCONV PerlIO* Perl_start_glob(pTHX_ SV *tmpglob, IO *io) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); |