This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make the peep recurse via PL_peepp
authorFlorian Ragwitz <rafl@debian.org>
Fri, 23 Jul 2010 06:38:13 +0000 (08:38 +0200)
committerFlorian Ragwitz <rafl@debian.org>
Sun, 25 Jul 2010 16:45:34 +0000 (18:45 +0200)
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!).

embed.fnc
embed.h
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/peep.t [new file with mode: 0644]
op.c
perl.h
pod/perlguts.pod
proto.h

index dc667b7..8f9cebf 100644 (file)
--- 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 (file)
--- a/embed.h
+++ b/embed.h
 #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)
index 3b90d95..9e5ebe8 100644 (file)
@@ -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 (file)
index 0000000..fa61dc3
--- /dev/null
@@ -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 (file)
--- 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 (file)
--- 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,
index 62e99bd..6a244b7 100644 (file)
@@ -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 (file)
--- 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);