Faster/Faster.pm

=head1 NAME

Faster - do some things faster

=head1 SYNOPSIS

 use Faster;

=head1 DESCRIPTION

=over 4

=cut

package Faster;

use strict;

BEGIN {
   our $VERSION = '0.01';

   require XSLoader;
   XSLoader::load __PACKAGE__, $VERSION;
}

use B ();

our $source;
our $label_next;
our $label_last;
our $label_redo;

my %flag;

for (split /\n/, <<EOF) {
   leavesub     unsafe
   leavesublv   unsafe
   return       unsafe
   flip         unsafe
   goto         unsafe
   last         unsafe
   redo         unsafe
   next         unsafe
   eval         unsafe
   leaveeval    unsafe
   entertry     unsafe
   substconst   unsafe
   formline     unsafe
   grepstart    unsafe
EOF
   my (undef, $op, @flags) = split /\s+/;

   undef $flag{$_}{$op}
      for ("known", @flags);
}

sub out_next {
   my ($op) = @_;

   $source .= "  PL_op = (OP *)${$op->next}L;\n";
   $source .= "  goto op_${$op->next};\n";
}

sub op_nextstate {
   my ($op) = @_;

   $source .= "  PL_curcop = (COP *)PL_op;\n";
   $source .= "  PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
   $source .= "  FREETMPS;\n";

   out_next $op;
}

sub op_pushmark {
   my ($op) = @_;

   $source .= "  PUSHMARK (PL_stack_sp);\n";

   out_next $op;
}

sub op_const {
   my ($op) = @_;

   $source .= "  { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";

   out_next $op;
}

*op_gv = \&op_const;

sub op_stringify {
   my ($op) = @_;

   $source .= "  { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";

   out_next $op;
}

# pattern const+ (or general push1)
# pattern pushmark return(?)
# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign

# pattern const method_named
sub xop_method_named {
   my ($op) = @_;

   my $ppaddr = ppaddr $op->type;

   $source .= <<EOF;
  {
    dSP;

    if (SvROK (TOPm1s) && SvOBJECT (SvRV (TOPm1s)))
      {
        static SV *last_stash, SV *last_res;
        SV *stash = SvSTASH (SvRV (TOPm1s));

        // simple polymorphic inline cache
        if (stash == last_stash)
          {
            dTARGET;
            SETTARG (last_res);
          }
        else
          {
            PUTBACK;
            ((PPFUNC)${ppaddr}L)(aTHX);\n";
            SPAGAIN;

            last_stash = stash;
            last_res   = TOPs;
          }
      }
  }
EOF

   out_next $op;
}

sub entersub {
   my ($cv) = @_;

   my %opsseen;
   my @ops;
   my @todo = $cv->START;

   while (my $op = shift @todo) {
      for (; $$op; $op = $op->next) {
         last if $opsseen{$$op}++;
         push @ops, $op;
         my $name = $op->name;
         if (B::class($op) eq "LOGOP") {
            push @todo, $op->other;
         } elsif ($name eq "subst" and ${ $op->pmreplstart }) {
            push @todo, $op->pmreplstart;
         } elsif ($name =~ /^enter(loop|iter)$/) {
#            if ($] > 5.009) {
#               $labels{${$op->nextop}} = "NEXT";
#               $labels{${$op->lastop}} = "LAST";
#               $labels{${$op->redoop}} = "REDO";
#            } else {
#               $labels{$op->nextop->seq} = "NEXT";
#               $labels{$op->lastop->seq} = "LAST";
#               $labels{$op->redoop->seq} = "REDO";         
#            }
         }
      }
   }

   local $source;

   $source = "typedef OP *(*PPFUNC)(pTHX);\n\n";
   
   $source .= "OP *func (pTHX)\n{\n  dTHX;\n";

   for my $op (@ops) {
      my $name = $op->name;
      my $ppaddr = ppaddr $op->type;

      $source .= "op_$$op: /* $name */\n";

      if (my $can = __PACKAGE__->can ("op_$name")) {
         $can->($op);
      } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
         $source .= "  PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
         $source .= "  if (PL_op == (OP *)${$op->other}L) goto op_${$op->other};\n";
         $source .= "  goto op_${$op->next};\n";
      } elsif (exists $flag{unsafe}{$name}) {
         $source .= "  return ((PPFUNC)${ppaddr}L)(aTHX);\n";
      } else {
         $source .= "  PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
         $source .= "  goto op_${$op->next};\n";
      }
   }

   $source .= "}\n";

   print <<EOF;
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
EOF
   print $source;
}

hook_entersub;

1;

=back

=head1 LIMITATIONS

Tainting and debugging will disable Faster.

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

Revision:	1.3
Committed:	Thu Mar 9 06:35:33 2006 UTC (20 years, 6 months ago) by root
Branch:	MAIN
Changes since 1.2:	+58 -3 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			Faster - do some things faster
4
5			=head1 SYNOPSIS
6
7			use Faster;
8
9			=head1 DESCRIPTION
10
11			=over 4
12
13			=cut
14
15			package Faster;
16
17			use strict;
18
19			BEGIN {
20			our $VERSION = '0.01';
21
22			require XSLoader;
23			XSLoader::load __PACKAGE__, $VERSION;
24			}
25
26			use B ();
27
28			our $source;
29			our $label_next;
30			our $label_last;
31			our $label_redo;
32
33	root	1.2	my %flag;
34
35			for (split /\n/, <<EOF) {
36			leavesub unsafe
37			leavesublv unsafe
38			return unsafe
39			flip unsafe
40			goto unsafe
41			last unsafe
42			redo unsafe
43			next unsafe
44			eval unsafe
45			leaveeval unsafe
46			entertry unsafe
47			substconst unsafe
48			formline unsafe
49			grepstart unsafe
50			EOF
51			my (undef, $op, @flags) = split /\s+/;
52
53			undef $flag{$_}{$op}
54			for ("known", @flags);
55			}
56
57			sub out_next {
58			my ($op) = @_;
59
60			$source .= " PL_op = (OP *)${$op->next}L;\n";
61			$source .= " goto op_${$op->next};\n";
62			}
63
64			sub op_nextstate {
65			my ($op) = @_;
66
67			$source .= " PL_curcop = (COP *)PL_op;\n";
68			$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
69			$source .= " FREETMPS;\n";
70
71			out_next $op;
72			}
73
74	root	1.3	sub op_pushmark {
75			my ($op) = @_;
76
77			$source .= " PUSHMARK (PL_stack_sp);\n";
78
79			out_next $op;
80			}
81
82	root	1.2	sub op_const {
83			my ($op) = @_;
84
85			$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
86
87			out_next $op;
88			}
89
90			*op_gv = \&op_const;
91
92	root	1.3	sub op_stringify {
93			my ($op) = @_;
94
95			$source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
96
97			out_next $op;
98			}
99
100			# pattern const+ (or general push1)
101			# pattern pushmark return(?)
102			# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
103
104			# pattern const method_named
105			sub xop_method_named {
106			my ($op) = @_;
107
108			my $ppaddr = ppaddr $op->type;
109
110			$source .= <<EOF;
111			{
112			dSP;
113
114			if (SvROK (TOPm1s) && SvOBJECT (SvRV (TOPm1s)))
115			{
116			static SV last_stash, SV last_res;
117			SV *stash = SvSTASH (SvRV (TOPm1s));
118
119			// simple polymorphic inline cache
120			if (stash == last_stash)
121			{
122			dTARGET;
123			SETTARG (last_res);
124			}
125			else
126			{
127			PUTBACK;
128			((PPFUNC)${ppaddr}L)(aTHX);\n";
129			SPAGAIN;
130
131			last_stash = stash;
132			last_res = TOPs;
133			}
134			}
135			}
136			EOF
137
138			out_next $op;
139			}
140
141	root	1.1	sub entersub {
142			my ($cv) = @_;
143
144			my %opsseen;
145			my @ops;
146			my @todo = $cv->START;
147
148			while (my $op = shift @todo) {
149			for (; $$op; $op = $op->next) {
150			last if $opsseen{$$op}++;
151			push @ops, $op;
152			my $name = $op->name;
153			if (B::class($op) eq "LOGOP") {
154			push @todo, $op->other;
155			} elsif ($name eq "subst" and ${ $op->pmreplstart }) {
156			push @todo, $op->pmreplstart;
157			} elsif ($name =~ /^enter(loop\|iter)$/) {
158			# if ($] > 5.009) {
159			# $labels{${$op->nextop}} = "NEXT";
160			# $labels{${$op->lastop}} = "LAST";
161			# $labels{${$op->redoop}} = "REDO";
162			# } else {
163			# $labels{$op->nextop->seq} = "NEXT";
164			# $labels{$op->lastop->seq} = "LAST";
165			# $labels{$op->redoop->seq} = "REDO";
166			# }
167			}
168			}
169			}
170
171	root	1.2	local $source;
172
173			$source = "typedef OP (PPFUNC)(pTHX);\n\n";
174
175	root	1.3	$source .= "OP *func (pTHX)\n{\n dTHX;\n";
176	root	1.2
177			for my $op (@ops) {
178			my $name = $op->name;
179			my $ppaddr = ppaddr $op->type;
180
181			$source .= "op_$$op: /* $name */\n";
182
183			if (my $can = __PACKAGE__->can ("op_$name")) {
184			$can->($op);
185			} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
186			$source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
187			$source .= " if (PL_op == (OP *)${$op->other}L) goto op_${$op->other};\n";
188			$source .= " goto op_${$op->next};\n";
189			} elsif (exists $flag{unsafe}{$name}) {
190			$source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n";
191			} else {
192			$source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
193			$source .= " goto op_${$op->next};\n";
194			}
195	root	1.1	}
196	root	1.2
197			$source .= "}\n";
198
199			print <<EOF;
200			#include "EXTERN.h"
201			#include "perl.h"
202			#include "XSUB.h"
203			EOF
204			print $source;
205	root	1.1	}
206
207			hook_entersub;
208
209			1;
210
211			=back
212
213	root	1.2	=head1 LIMITATIONS
214
215			Tainting and debugging will disable Faster.
216
217	root	1.1	=head1 AUTHOR
218
219			Marc Lehmann <schmorp@schmorp.de>
220			http://home.schmorp.de/
221
222			=cut
223