Faster/Faster.pm

=head1 NAME

Faster - do some things faster

=head1 SYNOPSIS

 use Faster;

=head1 DESCRIPTION

=over 4

=cut

package Faster;

use strict;
use Config;
use B ();
use Digest::MD5 ();
use DynaLoader ();

BEGIN {
   our $VERSION = '0.01';

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

my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
my $LINK    = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
my $LIBS    = "$Config{libs}";
my $_o      = $Config{_o};
my $_so     = ".so";

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
   require      unsafe

   pushmark     noasync
   padsv        noasync
   entersub     noasync
   aassign      noasync
   sassign      noasync
   rv2av        noasync
   nextstate    noasync
   gv           noasync
   gvsv         noasync
   add          noasync
   subtract     noasync
   multiply     noasync
   divide       noasync
   complement   noasync
   cond_expr    noasync
   and          noasync
   or           noasync
   not          noasync
   method_named noasync
   preinc       noasync
   postinc      noasync
   predec       noasync
   postdec      noasync
   stub         noasync
   unstack      noasync
   leaveloop    noasync
   shift        noasync
   aelemA       noasync
   aelemfast    noasync 
EOF
   my (undef, $op, @flags) = split /\s+/;

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

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

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

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

   my $name = $op->name;

   $name eq "entersub"
      ? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
      : "Perl_pp_$name (aTHX)"
}

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

   $source .= "  PL_curcop = (COP *)nextop;\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;
}

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

   $source .= <<EOF;
  {
    dSP;
    if (SvTRUE (TOPs))
      {
        --SP;
        PUTBACK;
        nextop = (OP *)${$op->other}L;
        goto op_${$op->other};
      }

    nextop = (OP *)${$op->next}L;
    goto op_${$op->next};
  }
EOF
}

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

   my $flags = $op->flags;
   my $target = $op->targ;

   $source .= <<EOF;
  {
    dSP;
    XPUSHs (PAD_SV ((PADOFFSET)$target));
    PUTBACK;
EOF
   if ($op->flags & B::OPf_MOD) {
      if ($op->private & B::OPpLVAL_INTRO) {
         $source .= "    SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
      } elsif ($op->private & B::OPpDEREF) {
         my $deref = $op->private & B::OPpDEREF;
         $source .= "    Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
      }
   }
   $source .= <<EOF;
  }
EOF

   out_next $op;
}

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

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

   $source .= <<EOF;
  {
    static HV *last_stash;
    static SV *last_res;

    SV *obj = *(PL_stack_base + TOPMARK + 1);

    if (SvROK (obj) && SvOBJECT (SvRV (obj)))
      {
        dSP;
        HV *stash = SvSTASH (SvRV (obj));

        /* simple "polymorphic" inline cache */
        if (stash == last_stash)
          {
            XPUSHs (last_res);
            PUTBACK;
          }
        else
          {
            PL_op = nextop;
            nextop = Perl_pp_method_named (aTHX);

            SPAGAIN;
            last_stash = stash;
            last_res   = TOPs;
          }
      }
    else
      {
        /* error case usually */
        PL_op = nextop;
        nextop = Perl_pp_method_named (aTHX);
      }
  }
EOF

   out_next $op;
}

sub cv2c {
   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 = <<EOF;
#define PERL_NO_GET_CONTEXT

#include <assert.h>

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/*typedef OP *(*PPFUNC)(pTHX);*/
   
OP *%%%FUNC%%% (pTHX)
{
  register OP *nextop = (OP *)${$ops[0]}L;
EOF

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

      $source .= "op_$$op: /* $name */\n";
      #$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
      #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#

      unless (exists $flag{noasync}{$name}) {
         $source .= "  PERL_ASYNC_CHECK ();\n";
      }

      if (my $can = __PACKAGE__->can ("op_$name")) {
         $can->($op);
      } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
         $source .= "  assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
         $source .= "  PL_op = nextop; nextop = " . (callop $op) . ";\n";
         $source .= "  if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
         $source .= "  assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
         $source .= "  goto op_${$op->next};\n";
      } elsif (exists $flag{unsafe}{$name}) {
         $source .= "  assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
         $source .= "  PL_op = nextop; return " . (callop $op) . ";\n";
      } else {
         $source .= "  assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
         $source .= "  PL_op = nextop; nextop = " . (callop $op) . ";\n";
         if ($name eq "entersub") {
            $source .= <<EOF;
while (nextop != (OP *)${$op->next})
  {
    PERL_ASYNC_CHECK ();
    PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
  }
EOF
         }
         $source .= "  assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
         $source .= "  goto op_${$op->next};\n";
      }
   }

   $source .= "}\n";
   #warn $source;

   $source
}

sub source2ptr {
   my ($source) = @_;

   my $md5 = Digest::MD5::md5_hex $source;
   $source =~ s/%%%FUNC%%%/Faster_$md5/;

   my $stem = "/tmp/$md5";

   unless (-e "$stem$_so") {
      open FILE, ">:raw", "$stem.c";
      print FILE $source;
      close FILE;
      system "$COMPILE -o $stem$_o $stem.c";
      system "$LINK -o $stem$_so $stem$_o $LIBS";
   }

#   warn $source;
   my $so = DynaLoader::dl_load_file "$stem$_so"
      or die "$stem$_so: $!";

   DynaLoader::dl_find_symbol $so, "Faster_$md5"
      or die "Faster_$md5: $!"
}

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

   eval {
      my $source = cv2c $cv;

       my $ptr = source2ptr $source;

       patch_cv $cv, $ptr;
   };

   warn $@ if $@;
}

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.4
Committed:	Thu Mar 9 22:32:17 2006 UTC (18 years, 4 months ago) by root
Branch:	MAIN
Changes since 1.3:	+197 -30 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	root	1.4	use Config;
19			use B ();
20			use Digest::MD5 ();
21			use DynaLoader ();
22	root	1.1
23			BEGIN {
24			our $VERSION = '0.01';
25
26			require XSLoader;
27			XSLoader::load __PACKAGE__, $VERSION;
28			}
29
30	root	1.4	my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
31			my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
32			my $LIBS = "$Config{libs}";
33			my $_o = $Config{_o};
34			my $_so = ".so";
35	root	1.1
36			our $source;
37			our $label_next;
38			our $label_last;
39			our $label_redo;
40
41	root	1.2	my %flag;
42
43			for (split /\n/, <<EOF) {
44			leavesub unsafe
45			leavesublv unsafe
46			return unsafe
47			flip unsafe
48			goto unsafe
49			last unsafe
50			redo unsafe
51			next unsafe
52			eval unsafe
53			leaveeval unsafe
54			entertry unsafe
55			substconst unsafe
56			formline unsafe
57			grepstart unsafe
58	root	1.4	require unsafe
59
60			pushmark noasync
61			padsv noasync
62			entersub noasync
63			aassign noasync
64			sassign noasync
65			rv2av noasync
66			nextstate noasync
67			gv noasync
68			gvsv noasync
69			add noasync
70			subtract noasync
71			multiply noasync
72			divide noasync
73			complement noasync
74			cond_expr noasync
75			and noasync
76			or noasync
77			not noasync
78			method_named noasync
79			preinc noasync
80			postinc noasync
81			predec noasync
82			postdec noasync
83			stub noasync
84			unstack noasync
85			leaveloop noasync
86			shift noasync
87			aelemA noasync
88			aelemfast noasync
89	root	1.2	EOF
90			my (undef, $op, @flags) = split /\s+/;
91
92			undef $flag{$_}{$op}
93			for ("known", @flags);
94			}
95
96			sub out_next {
97			my ($op) = @_;
98
99	root	1.4	$source .= " nextop = (OP *)${$op->next}L;\n";
100	root	1.2	$source .= " goto op_${$op->next};\n";
101			}
102
103	root	1.4	sub callop {
104			my ($op) = @_;
105
106			my $name = $op->name;
107
108			$name eq "entersub"
109			? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
110			: "Perl_pp_$name (aTHX)"
111			}
112
113	root	1.2	sub op_nextstate {
114			my ($op) = @_;
115
116	root	1.4	$source .= " PL_curcop = (COP *)nextop;\n";
117	root	1.2	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
118			$source .= " FREETMPS;\n";
119
120			out_next $op;
121			}
122
123	root	1.3	sub op_pushmark {
124			my ($op) = @_;
125
126			$source .= " PUSHMARK (PL_stack_sp);\n";
127
128			out_next $op;
129			}
130
131	root	1.2	sub op_const {
132			my ($op) = @_;
133
134			$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
135
136			out_next $op;
137			}
138
139			*op_gv = \&op_const;
140
141	root	1.3	sub op_stringify {
142			my ($op) = @_;
143
144			$source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
145
146			out_next $op;
147			}
148
149	root	1.4	sub op_and {
150			my ($op) = @_;
151
152			$source .= <<EOF;
153			{
154			dSP;
155			if (SvTRUE (TOPs))
156			{
157			--SP;
158			PUTBACK;
159			nextop = (OP *)${$op->other}L;
160			goto op_${$op->other};
161			}
162
163			nextop = (OP *)${$op->next}L;
164			goto op_${$op->next};
165			}
166			EOF
167			}
168
169			sub op_padsv {
170			my ($op) = @_;
171
172			my $flags = $op->flags;
173			my $target = $op->targ;
174
175			$source .= <<EOF;
176			{
177			dSP;
178			XPUSHs (PAD_SV ((PADOFFSET)$target));
179			PUTBACK;
180			EOF
181			if ($op->flags & B::OPf_MOD) {
182			if ($op->private & B::OPpLVAL_INTRO) {
183			$source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
184			} elsif ($op->private & B::OPpDEREF) {
185			my $deref = $op->private & B::OPpDEREF;
186			$source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
187			}
188			}
189			$source .= <<EOF;
190			}
191			EOF
192
193			out_next $op;
194			}
195
196	root	1.3	# pattern const+ (or general push1)
197			# pattern pushmark return(?)
198			# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
199
200			# pattern const method_named
201	root	1.4	sub op_method_named {
202	root	1.3	my ($op) = @_;
203
204			$source .= <<EOF;
205			{
206	root	1.4	static HV *last_stash;
207			static SV *last_res;
208
209			SV obj = (PL_stack_base + TOPMARK + 1);
210	root	1.3
211	root	1.4	if (SvROK (obj) && SvOBJECT (SvRV (obj)))
212	root	1.3	{
213	root	1.4	dSP;
214			HV *stash = SvSTASH (SvRV (obj));
215	root	1.3
216	root	1.4	/* simple "polymorphic" inline cache */
217	root	1.3	if (stash == last_stash)
218			{
219	root	1.4	XPUSHs (last_res);
220			PUTBACK;
221	root	1.3	}
222			else
223			{
224	root	1.4	PL_op = nextop;
225			nextop = Perl_pp_method_named (aTHX);
226
227	root	1.3	SPAGAIN;
228			last_stash = stash;
229			last_res = TOPs;
230			}
231			}
232	root	1.4	else
233			{
234			/* error case usually */
235			PL_op = nextop;
236			nextop = Perl_pp_method_named (aTHX);
237			}
238	root	1.3	}
239			EOF
240
241			out_next $op;
242			}
243
244	root	1.4	sub cv2c {
245	root	1.1	my ($cv) = @_;
246
247			my %opsseen;
248			my @ops;
249			my @todo = $cv->START;
250
251			while (my $op = shift @todo) {
252			for (; $$op; $op = $op->next) {
253			last if $opsseen{$$op}++;
254			push @ops, $op;
255			my $name = $op->name;
256			if (B::class($op) eq "LOGOP") {
257			push @todo, $op->other;
258			} elsif ($name eq "subst" and ${ $op->pmreplstart }) {
259			push @todo, $op->pmreplstart;
260			} elsif ($name =~ /^enter(loop\|iter)$/) {
261			# if ($] > 5.009) {
262			# $labels{${$op->nextop}} = "NEXT";
263			# $labels{${$op->lastop}} = "LAST";
264			# $labels{${$op->redoop}} = "REDO";
265			# } else {
266			# $labels{$op->nextop->seq} = "NEXT";
267			# $labels{$op->lastop->seq} = "LAST";
268			# $labels{$op->redoop->seq} = "REDO";
269			# }
270			}
271			}
272			}
273
274	root	1.4	local $source = <<EOF;
275			#define PERL_NO_GET_CONTEXT
276
277			#include <assert.h>
278
279			#include "EXTERN.h"
280			#include "perl.h"
281			#include "XSUB.h"
282	root	1.2
283	root	1.4	/typedef OP (PPFUNC)(pTHX);/
284	root	1.2
285	root	1.4	OP *%%%FUNC%%% (pTHX)
286			{
287			register OP nextop = (OP )${$ops[0]}L;
288			EOF
289	root	1.2
290			for my $op (@ops) {
291			my $name = $op->name;
292			my $ppaddr = ppaddr $op->type;
293
294			$source .= "op_$$op: /* $name */\n";
295	root	1.4	#$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
296			#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
297
298			unless (exists $flag{noasync}{$name}) {
299			$source .= " PERL_ASYNC_CHECK ();\n";
300			}
301	root	1.2
302			if (my $can = __PACKAGE__->can ("op_$name")) {
303			$can->($op);
304			} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
305	root	1.4	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
306			$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
307			$source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
308			$source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
309	root	1.2	$source .= " goto op_${$op->next};\n";
310			} elsif (exists $flag{unsafe}{$name}) {
311	root	1.4	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
312			$source .= " PL_op = nextop; return " . (callop $op) . ";\n";
313	root	1.2	} else {
314	root	1.4	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
315			$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
316			if ($name eq "entersub") {
317			$source .= <<EOF;
318			while (nextop != (OP *)${$op->next})
319			{
320			PERL_ASYNC_CHECK ();
321			PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
322			}
323			EOF
324			}
325			$source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
326	root	1.2	$source .= " goto op_${$op->next};\n";
327			}
328	root	1.1	}
329	root	1.2
330			$source .= "}\n";
331	root	1.4	#warn $source;
332	root	1.2
333	root	1.4	$source
334			}
335
336			sub source2ptr {
337			my ($source) = @_;
338
339			my $md5 = Digest::MD5::md5_hex $source;
340			$source =~ s/%%%FUNC%%%/Faster_$md5/;
341
342			my $stem = "/tmp/$md5";
343
344			unless (-e "$stem$_so") {
345			open FILE, ">:raw", "$stem.c";
346			print FILE $source;
347			close FILE;
348			system "$COMPILE -o $stem$_o $stem.c";
349			system "$LINK -o $stem$_so $stem$_o $LIBS";
350			}
351
352			# warn $source;
353			my $so = DynaLoader::dl_load_file "$stem$_so"
354			or die "$stem$_so: $!";
355
356			DynaLoader::dl_find_symbol $so, "Faster_$md5"
357			or die "Faster_$md5: $!"
358			}
359
360			sub entersub {
361			my ($cv) = @_;
362
363			eval {
364			my $source = cv2c $cv;
365
366			my $ptr = source2ptr $source;
367
368			patch_cv $cv, $ptr;
369			};
370
371			warn $@ if $@;
372	root	1.1	}
373
374			hook_entersub;
375
376			1;
377
378			=back
379
380	root	1.2	=head1 LIMITATIONS
381
382			Tainting and debugging will disable Faster.
383
384	root	1.1	=head1 AUTHOR
385
386			Marc Lehmann <schmorp@schmorp.de>
387			http://home.schmorp.de/
388
389			=cut
390