In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/844fcee5cda65ac773b3d0e73dbcd39ed06b38d8?hp=a767f83cfc2d7d70f2c373cc53d3166863982d0a>
- Log ----------------------------------------------------------------- commit 844fcee5cda65ac773b3d0e73dbcd39ed06b38d8 Author: Florian Ragwitz <[email protected]> Date: Sun Jul 25 19:03:29 2010 +0200 perldelta up to 65bfe90c M pod/perl5134delta.pod commit 65bfe90c4b4ea5706a50067179e60d4e8de6807a Author: Florian Ragwitz <[email protected]> Date: Fri Jul 23 08:38:13 2010 +0200 Make the peep recurse via PL_peepp Also allows extensions, when delegating to Perl_peep, to specify what function it should use when recursing into a part of the op tree. The usecase for this are extensions like namespace::alias, which need to hook into the peep to do their thing. With this change they can stop copying the whole peep only to add tiny bits of new behaviour to it, allowing them to work easier on a large variety of perls, without having to maintain one peep which works on all of them (which is HARD!). M embed.fnc M embed.h M ext/XS-APItest/APItest.xs A ext/XS-APItest/t/peep.t M op.c M perl.h M pod/perlguts.pod M proto.h ----------------------------------------------------------------------- Summary of changes: embed.fnc | 2 +- embed.h | 2 +- ext/XS-APItest/APItest.xs | 57 +++++++++++++++++++++++++++++++++++++++--- ext/XS-APItest/t/peep.t | 39 +++++++++++++++++++++++++++++ op.c | 25 ++++++++++++------ perl.h | 8 +++++- pod/perl5134delta.pod | 10 ++++++- pod/perlguts.pod | 60 ++++++++++++++++++++++++++++++++++++++++++-- proto.h | 6 +++- 9 files changed, 188 insertions(+), 21 deletions(-) create mode 100644 ext/XS-APItest/t/peep.t diff --git a/embed.fnc b/embed.fnc index dc667b7..8f9cebf 100644 --- a/embed.fnc +++ b/embed.fnc @@ -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) diff --git a/embed.h b/embed.h index 07aa965..5312d22 100644 --- a/embed.h +++ b/embed.h @@ -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 3b90d95..9e5ebe8 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 0000000..fa61dc3 --- /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'); diff --git a/op.c b/op.c index 5a0962b..9539248 100644 --- a/op.c +++ b/op.c @@ -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: diff --git a/perl.h b/perl.h index 7fcff2f..32cf787 100644 --- a/perl.h +++ b/perl.h @@ -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/perl5134delta.pod b/pod/perl5134delta.pod index ae8c452..a5baed6 100644 --- a/pod/perl5134delta.pod +++ b/pod/perl5134delta.pod @@ -1,7 +1,7 @@ =encoding utf8 =for rafl -changelogged up to commit 34edcf0c +changelogged up to commit 65bfe90c * PERL_STATIC_INLINE might want to be mentioned =head1 NAME @@ -352,6 +352,14 @@ C<PERL_SUBVERSION>, explicitly marking them as incompatible with each other. Maintainance releases of stable perl's will continue to make no intentionally incompatible changes. +=item Make extending the peephole optimizer easier + +As of version 5.8, extension authors were allowed to replace perl's peephole +optimizer function. However, this was B<very> hard to do, as there was no way to +add new optimizations without having to copy large parts of perl's original +optimizer. This problem is now solved by a rework of the optimizer extension +API. See L<perlguts/"Compile pass 3: peephole optimization"> for details. + =back =head1 Selected Bug Fixes diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 62e99bd..6a244b7 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 diff --git a/proto.h b/proto.h index 8ad7e66..274509a 100644 --- a/proto.h +++ b/proto.h @@ -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); -- Perl5 Master Repository
