cvsroot/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;
}

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

   my $targ = $op->targ;
   my $private = $op->private;

   $source .= "  {\n";

   if ($op->flags & B::OPf_SPECIAL) {
      $source .= "    AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
   } else {
      $source .= "    AV *av = GvAV ((GV *)${$op->sv}L);\n";
   }

   if ($op->flags & B::OPf_MOD) {
      $source .= "    SV *sv = *av_fetch (av, $private, 1);\n";
   } else {
      $source .= "    SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
   }

   if (!($op->flags & B::OPf_MOD)) {
      $source .= "    if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
   }

   $source .= "    dSP;\n";
   $source .= "    XPUSHs (sv);\n";
   $source .= "    PUTBACK;\n";
   $source .= "  }\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 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.6
Committed:	Fri Mar 10 00:11:44 2006 UTC (20 years, 6 months ago) by root
Branch:	MAIN
Changes since 1.5:	+32 -0 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.6	sub op_aelemfast {
207			my ($op) = @_;
208
209			my $targ = $op->targ;
210			my $private = $op->private;
211
212			$source .= " {\n";
213
214			if ($op->flags & B::OPf_SPECIAL) {
215			$source .= " AV av = (AV)PAD_SV((PADOFFSET)$targ);\n";
216			} else {
217			$source .= " AV av = GvAV ((GV )${$op->sv}L);\n";
218			}
219
220			if ($op->flags & B::OPf_MOD) {
221			$source .= " SV sv = av_fetch (av, $private, 1);\n";
222			} else {
223			$source .= " SV *svp = av_fetch (av, $private, 0); SV sv = svp ? *svp : &PL_sv_undef;\n";
224			}
225
226			if (!($op->flags & B::OPf_MOD)) {
227			$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
228			}
229
230			$source .= " dSP;\n";
231			$source .= " XPUSHs (sv);\n";
232			$source .= " PUTBACK;\n";
233			$source .= " }\n";
234
235			out_next $op;
236			}
237
238	root	1.3	# pattern const+ (or general push1)
239			# pattern pushmark return(?)
240			# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
241
242			# pattern const method_named
243	root	1.4	sub op_method_named {
244	root	1.3	my ($op) = @_;
245
246			$source .= <<EOF;
247			{
248	root	1.4	static HV *last_stash;
249			static SV *last_res;
250
251			SV obj = (PL_stack_base + TOPMARK + 1);
252	root	1.3
253	root	1.4	if (SvROK (obj) && SvOBJECT (SvRV (obj)))
254	root	1.3	{
255	root	1.4	dSP;
256			HV *stash = SvSTASH (SvRV (obj));
257	root	1.3
258	root	1.4	/* simple "polymorphic" inline cache */
259	root	1.3	if (stash == last_stash)
260			{
261	root	1.4	XPUSHs (last_res);
262			PUTBACK;
263	root	1.3	}
264			else
265			{
266	root	1.4	PL_op = nextop;
267			nextop = Perl_pp_method_named (aTHX);
268
269	root	1.3	SPAGAIN;
270			last_stash = stash;
271			last_res = TOPs;
272			}
273			}
274	root	1.4	else
275			{
276			/* error case usually */
277			PL_op = nextop;
278			nextop = Perl_pp_method_named (aTHX);
279			}
280	root	1.3	}
281			EOF
282
283			out_next $op;
284			}
285
286	root	1.4	sub cv2c {
287	root	1.1	my ($cv) = @_;
288
289			my %opsseen;
290			my @ops;
291			my @todo = $cv->START;
292
293			while (my $op = shift @todo) {
294			for (; $$op; $op = $op->next) {
295			last if $opsseen{$$op}++;
296			push @ops, $op;
297			my $name = $op->name;
298			if (B::class($op) eq "LOGOP") {
299			push @todo, $op->other;
300			} elsif ($name eq "subst" and ${ $op->pmreplstart }) {
301			push @todo, $op->pmreplstart;
302			} elsif ($name =~ /^enter(loop\|iter)$/) {
303			# if ($] > 5.009) {
304			# $labels{${$op->nextop}} = "NEXT";
305			# $labels{${$op->lastop}} = "LAST";
306			# $labels{${$op->redoop}} = "REDO";
307			# } else {
308			# $labels{$op->nextop->seq} = "NEXT";
309			# $labels{$op->lastop->seq} = "LAST";
310			# $labels{$op->redoop->seq} = "REDO";
311			# }
312			}
313			}
314			}
315
316	root	1.4	local $source = <<EOF;
317			#define PERL_NO_GET_CONTEXT
318
319			#include <assert.h>
320
321			#include "EXTERN.h"
322			#include "perl.h"
323			#include "XSUB.h"
324	root	1.2
325	root	1.4	/typedef OP (PPFUNC)(pTHX);/
326	root	1.2
327	root	1.4	OP *%%%FUNC%%% (pTHX)
328			{
329			register OP nextop = (OP )${$ops[0]}L;
330			EOF
331	root	1.2
332			for my $op (@ops) {
333			my $name = $op->name;
334			my $ppaddr = ppaddr $op->type;
335
336			$source .= "op_$$op: /* $name */\n";
337	root	1.4	#$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
338			#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
339
340			unless (exists $flag{noasync}{$name}) {
341			$source .= " PERL_ASYNC_CHECK ();\n";
342			}
343	root	1.2
344			if (my $can = __PACKAGE__->can ("op_$name")) {
345			$can->($op);
346	root	1.5	} elsif (exists $flag{unsafe}{$name}) {
347			$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
348			$source .= " PL_op = nextop; return " . (callop $op) . ";\n";
349	root	1.2	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
350	root	1.4	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
351			$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
352			$source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
353			$source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
354	root	1.5	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
355	root	1.2	} else {
356	root	1.4	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
357			$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
358			if ($name eq "entersub") {
359			$source .= <<EOF;
360			while (nextop != (OP *)${$op->next})
361			{
362			PERL_ASYNC_CHECK ();
363			PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
364			}
365			EOF
366			}
367			$source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
368	root	1.5	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
369	root	1.2	}
370	root	1.1	}
371	root	1.2
372			$source .= "}\n";
373	root	1.4	#warn $source;
374	root	1.2
375	root	1.4	$source
376			}
377
378			sub source2ptr {
379			my ($source) = @_;
380
381			my $md5 = Digest::MD5::md5_hex $source;
382			$source =~ s/%%%FUNC%%%/Faster_$md5/;
383
384			my $stem = "/tmp/$md5";
385
386			unless (-e "$stem$_so") {
387			open FILE, ">:raw", "$stem.c";
388			print FILE $source;
389			close FILE;
390			system "$COMPILE -o $stem$_o $stem.c";
391			system "$LINK -o $stem$_so $stem$_o $LIBS";
392			}
393
394			# warn $source;
395			my $so = DynaLoader::dl_load_file "$stem$_so"
396			or die "$stem$_so: $!";
397
398			DynaLoader::dl_find_symbol $so, "Faster_$md5"
399			or die "Faster_$md5: $!"
400			}
401
402			sub entersub {
403			my ($cv) = @_;
404
405			eval {
406			my $source = cv2c $cv;
407
408			my $ptr = source2ptr $source;
409
410			patch_cv $cv, $ptr;
411			};
412
413			warn $@ if $@;
414	root	1.1	}
415
416			hook_entersub;
417
418			1;
419
420			=back
421
422	root	1.2	=head1 LIMITATIONS
423
424			Tainting and debugging will disable Faster.
425
426	root	1.1	=head1 AUTHOR
427
428			Marc Lehmann <schmorp@schmorp.de>
429			http://home.schmorp.de/
430
431			=cut
432