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
   match        unsafe  todo
   subst        unsafe  todo
   entereval    unsafe  todo
   mapstart     unsafe  todo

   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) = @_;

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

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

   my $name = $op->name;

   $name eq "entersub"
      ? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
      : $name eq "mapstart"
        ? "Perl_pp_grepstart (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};
      }
  }
EOF

   out_next $op;
}

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