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";

# we don't need no steenking PIC on x86
$COMPILE =~ s/-f(?:PIC|pic)//g
   if $Config{archname} =~ /^(i[3456]86)-/;

my $opt_assert = 1;

our $source;

my @ops;
my $op;
my $op_name;
my @loop;

my %flag;

# complex flag steting is no longer required, rewrite this ugly code
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
   formline     unsafe
   grepstart    unsafe
   mapstart     unsafe
   substcont    unsafe
   entereval    unsafe noasync  todo
   require      unsafe

   mapstart     noasync
   grepstart    noasync
   match        noasync

   last         noasync
   next         noasync
   redo         noasync
   seq          noasync
   pushmark     noasync extend=0
   padsv        noasync extend=1
   padav        noasync extend=1
   padhv        noasync extend=1
   padany       noasync extend=1
   entersub     noasync
   aassign      noasync
   sassign      noasync
   rv2av        noasync
   rv2cv        noasync
   rv2gv        noasync
   rv2hv        noasync
   refgen       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
   defined      noasync
   method_named noasync
   preinc       noasync
   postinc      noasync
   predec       noasync
   postdec      noasync
   stub         noasync
   unstack      noasync
   leaveloop    noasync
   aelem        noasync
   aelemfast    noasync 
   helem        noasync
   pushre       noasync
   subst        noasync
   const        noasync extend=1
   list         noasync
   join         noasync
   split        noasync
   concat       noasync
   push         noasync
   pop          noasync
   shift        noasync
   unshift      noasync
   length       noasync
   substr       noasync
   stringify    noasync
   eq           noasync
   ne           noasync
   gt           noasync
   lt           noasync
   ge           noasync
   le           noasync
   enteriter    noasync
   ord          noasync

   iter         async
EOF
   my (undef, $op, @flags) = split /\s+/;

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

my %callop = (
   entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
   mapstart => "Perl_pp_grepstart (aTHX)",
);

sub callop {
   $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
}

sub assert {
   return unless $opt_assert;
   $source .= "  assert ((\"$op_name\", ($_[0])));\n";
}

sub out_callop {
   assert "nextop == (OP *)$$op";
   $source .= "  PL_op = nextop; nextop = " . (callop $op) . ";\n";
}

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

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

   out_jump_next;
}

sub out_linear {
   out_callop;
   out_jump_next;
}

sub out_cond_jump {
   $source .= "  if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
}

sub op_entersub {
   out_callop;
   $source .= "  RUNOPS_TILL ((OP *)${$op->next}L);\n";
   out_jump_next;
}

*op_require = \&op_entersub;

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

   out_next;
}

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

   out_next;
}

if ($Config{useithreads} ne "define") {
   # disable optimisations on ithreads

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

      out_next;
   };

   *op_gv = \&op_const;

   *op_aelemfast = sub {
      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_gvsv = sub {
      $source .= "  {\n";
      $source .= "    dSP;\n";
      $source .= "    EXTEND (SP, 1);\n";

      if ($op->private & B::OPpLVAL_INTRO) {
        $source .= "    PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
      } else {
        $source .= "    PUSHs (GvSV ((GV *)${$op->sv}L));\n";
      }

      $source .= "    PUTBACK;\n";
      $source .= "  }\n";

      out_next;
   };
}

# does kill Crossfire/res2pm
sub op_stringify {
   my $targ = $op->targ;

   $source .= <<EOF;
  {
    dSP;
    SV *targ = PAD_SV ((PADOFFSET)$targ);
    sv_copypv (TARG, TOPs);
    SETTARG;
    PUTBACK;
  }
EOF

   out_next;
}

sub op_and {
   $source .= <<EOF;
  {
    dSP;

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

   out_next;
}

sub op_or {
   $source .= <<EOF;
  {
    dSP;

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

   out_next;
}

sub op_padsv {
   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;
}

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

# pattern const method_named
sub op_method_named {
   $source .= <<EOF;
  {
    static HV *last_stash;
    static SV *last_cv;
    static U32 last_sub_generation;

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

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

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

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

   out_next;
}

sub op_grepstart {
   out_callop;
   out_cond_jump $op->next->other;
   out_jump_next;
}

*op_mapstart = \&op_grepstart;

sub op_substcont {
   out_callop;
   out_cond_jump $op->other->pmreplstart;
   assert "nextop == (OP *)${$op->other->next}L";
   $source .= "  goto op_${$op->other->next};\n";
}

sub out_break_op {
   my ($idx) = @_;

   out_callop;

   out_cond_jump $_->[$idx]
      for reverse @loop;

   $source .= "  return nextop;\n";
}

sub xop_next {
   out_break_op 0;
}

sub op_last {
   out_break_op 1;
}

sub xop_redo {
   out_break_op 2;
}

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

   @loop = ();

   my %opsseen;
   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;
         my $class = B::class $op;

         if ($class eq "LOGOP") {
            unshift @todo, $op->other; # unshift vs. push saves jumps
         } elsif ($class eq "PMOP") {
            unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
         } elsif ($class eq "LOOP") {
            push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
         }
      }
   }

   local $source = <<EOF;
OP *%%%FUNC%%% (pTHX)
{
  register OP *nextop = (OP *)${$ops[0]}L;
EOF

   while (@ops) {
      $op = shift @ops;
      $op_name = $op->name;

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

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

      if (my $can = __PACKAGE__->can ("op_$op_name")) {
         # handcrafted replacement
         $can->($op);

      } elsif (exists $flag{unsafe}{$op_name}) {
         # unsafe, return to interpreter
         assert "nextop == (OP *)$$op";
         $source .= "  return nextop;\n";

      } elsif ("LOGOP" eq B::class $op) {
         # logical operation with optionaö branch
         out_callop;
         out_cond_jump $op->other;
         out_jump_next;

      } elsif ("PMOP" eq B::class $op) {
         # regex-thingy
         out_callop;
         out_cond_jump $op->pmreplroot if ${$op->pmreplroot};
         out_jump_next;

      } else {
         # normal operator, linear execution
         out_linear;
      }
   }

   $op_name = "func exit"; assert (0);

   $source .= <<EOF;
op_0:
  return 0;
}
EOF
   #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 <<EOF;
#define PERL_NO_GET_CONTEXT

#include <assert.h>

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

#define RUNOPS_TILL(op)                                         \\
  while (nextop != (op))                                        \\
    {                                                           \\
      PERL_ASYNC_CHECK ();                                      \\
      PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);        \\
    }

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

   # always compile the whole stash
#   my @stash = $cv->STASH->ARRAY;
#   warn join ":", @stash;
#   exit;

   eval {
      my $source = cv2c $cv;

      my $ptr = source2ptr $source;

      patch_cv $cv, $ptr;
   };

   warn $@ if $@;
}

hook_entersub;

1;

=back

=head1 BUGS/LIMITATIONS

Perl will check much less often for asynchronous signals in
Faster-compiled code. It tries to check on every function call, loop
iteration and every I/O operator, though.

The following things will disable Faster. If you manage to enable them at
runtime, bad things will happen.

 enabled tainting
 enabled debugging

This will dramatically reduce Faster's performance:

 threads (but you don't care about speed if you use threads anyway)

These constructs will force the use of the interpreter as soon as they are
being executed, for the rest of the currently executed:

 .., ... (flipflop operators)
 goto
 next, redo (but not well-behaved last's)
 eval
 require
 any use of formats

=head1 AUTHOR

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

=cut

Revision:	1.13
Committed:	Fri Mar 10 18:53:49 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.12:	+5 -1 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	root	1.13	# we don't need no steenking PIC on x86
37			$COMPILE =~ s/-f(?:PIC\|pic)//g
38			if $Config{archname} =~ /^(i[3456]86)-/;
39
40	root	1.11	my $opt_assert = 1;
41
42	root	1.1	our $source;
43
44	root	1.8	my @ops;
45			my $op;
46			my $op_name;
47	root	1.11	my @loop;
48	root	1.8
49	root	1.2	my %flag;
50
51	root	1.11	# complex flag steting is no longer required, rewrite this ugly code
52	root	1.2	for (split /\n/, <<EOF) {
53			leavesub unsafe
54			leavesublv unsafe
55			return unsafe
56			flip unsafe
57			goto unsafe
58			last unsafe
59			redo unsafe
60			next unsafe
61			eval unsafe
62			leaveeval unsafe
63			entertry unsafe
64			formline unsafe
65			grepstart unsafe
66	root	1.11	mapstart unsafe
67			substcont unsafe
68			entereval unsafe noasync todo
69	root	1.4	require unsafe
70
71	root	1.11	mapstart noasync
72			grepstart noasync
73	root	1.12	match noasync
74	root	1.11
75			last noasync
76			next noasync
77			redo noasync
78	root	1.8	seq noasync
79	root	1.11	pushmark noasync extend=0
80	root	1.8	padsv noasync extend=1
81			padav noasync extend=1
82			padhv noasync extend=1
83			padany noasync extend=1
84	root	1.4	entersub noasync
85			aassign noasync
86			sassign noasync
87			rv2av noasync
88	root	1.8	rv2cv noasync
89			rv2gv noasync
90			rv2hv noasync
91			refgen noasync
92	root	1.4	nextstate noasync
93			gv noasync
94			gvsv noasync
95			add noasync
96			subtract noasync
97			multiply noasync
98			divide noasync
99			complement noasync
100			cond_expr noasync
101			and noasync
102			or noasync
103			not noasync
104	root	1.8	defined noasync
105	root	1.4	method_named noasync
106			preinc noasync
107			postinc noasync
108			predec noasync
109			postdec noasync
110			stub noasync
111			unstack noasync
112			leaveloop noasync
113	root	1.8	aelem noasync
114	root	1.4	aelemfast noasync
115	root	1.8	helem noasync
116			pushre noasync
117	root	1.11	subst noasync
118	root	1.8	const noasync extend=1
119			list noasync
120			join noasync
121			split noasync
122			concat noasync
123			push noasync
124			pop noasync
125			shift noasync
126			unshift noasync
127			length noasync
128			substr noasync
129			stringify noasync
130			eq noasync
131			ne noasync
132			gt noasync
133			lt noasync
134			ge noasync
135			le noasync
136			enteriter noasync
137	root	1.11	ord noasync
138	root	1.8
139			iter async
140	root	1.2	EOF
141			my (undef, $op, @flags) = split /\s+/;
142
143			undef $flag{$_}{$op}
144			for ("known", @flags);
145			}
146
147	root	1.11	my %callop = (
148			entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
149			mapstart => "Perl_pp_grepstart (aTHX)",
150			);
151
152	root	1.8	sub callop {
153	root	1.11	$callop{$op_name} \|\| "Perl_pp_$op_name (aTHX)"
154			}
155
156			sub assert {
157			return unless $opt_assert;
158			$source .= " assert ((\"$op_name\", ($_[0])));\n";
159			}
160
161			sub out_callop {
162			assert "nextop == (OP *)$$op";
163			$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
164	root	1.8	}
165
166	root	1.11	sub out_jump_next {
167			assert "nextop == (OP *)${$op->next}";
168			$source .= " goto op_${$op->next};\n";
169	root	1.2	}
170
171	root	1.9	sub out_next {
172			$source .= " nextop = (OP *)${$op->next}L;\n";
173
174	root	1.11	out_jump_next;
175	root	1.9	}
176
177	root	1.8	sub out_linear {
178	root	1.11	out_callop;
179			out_jump_next;
180			}
181
182			sub out_cond_jump {
183			$source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
184			}
185	root	1.4
186	root	1.11	sub op_entersub {
187			out_callop;
188			$source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
189			out_jump_next;
190	root	1.4	}
191
192	root	1.11	*op_require = \&op_entersub;
193
194	root	1.2	sub op_nextstate {
195	root	1.4	$source .= " PL_curcop = (COP *)nextop;\n";
196	root	1.2	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
197			$source .= " FREETMPS;\n";
198
199	root	1.8	out_next;
200	root	1.2	}
201
202	root	1.3	sub op_pushmark {
203			$source .= " PUSHMARK (PL_stack_sp);\n";
204
205	root	1.8	out_next;
206	root	1.3	}
207
208	root	1.13	if ($Config{useithreads} ne "define") {
209	root	1.8	# disable optimisations on ithreads
210
211			*op_const = sub {
212			$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
213
214			out_next;
215			};
216
217			*op_gv = \&op_const;
218
219			*op_aelemfast = sub {
220			my $targ = $op->targ;
221			my $private = $op->private;
222
223			$source .= " {\n";
224
225			if ($op->flags & B::OPf_SPECIAL) {
226			$source .= " AV av = (AV)PAD_SV((PADOFFSET)$targ);\n";
227			} else {
228			$source .= " AV av = GvAV ((GV )${$op->sv}L);\n";
229			}
230
231			if ($op->flags & B::OPf_MOD) {
232			$source .= " SV sv = av_fetch (av, $private, 1);\n";
233			} else {
234			$source .= " SV *svp = av_fetch (av, $private, 0); SV sv = svp ? *svp : &PL_sv_undef;\n";
235			}
236
237			if (!($op->flags & B::OPf_MOD)) {
238			$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
239			}
240
241			$source .= " dSP;\n";
242			$source .= " XPUSHs (sv);\n";
243			$source .= " PUTBACK;\n";
244			$source .= " }\n";
245
246			out_next;
247			};
248	root	1.2
249	root	1.8	*op_gvsv = sub {
250			$source .= " {\n";
251			$source .= " dSP;\n";
252			$source .= " EXTEND (SP, 1);\n";
253	root	1.2
254	root	1.8	if ($op->private & B::OPpLVAL_INTRO) {
255			$source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
256			} else {
257			$source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
258			}
259
260			$source .= " PUTBACK;\n";
261			$source .= " }\n";
262
263			out_next;
264			};
265	root	1.2	}
266
267	root	1.12	# does kill Crossfire/res2pm
268			sub op_stringify {
269			my $targ = $op->targ;
270
271			$source .= <<EOF;
272			{
273			dSP;
274			SV *targ = PAD_SV ((PADOFFSET)$targ);
275			sv_copypv (TARG, TOPs);
276			SETTARG;
277			PUTBACK;
278			}
279			EOF
280	root	1.3
281	root	1.8	out_next;
282	root	1.3	}
283
284	root	1.4	sub op_and {
285			$source .= <<EOF;
286			{
287			dSP;
288	root	1.5
289	root	1.4	if (SvTRUE (TOPs))
290			{
291			--SP;
292			PUTBACK;
293			nextop = (OP *)${$op->other}L;
294			goto op_${$op->other};
295			}
296			}
297			EOF
298	root	1.5
299	root	1.8	out_next;
300	root	1.4	}
301
302	root	1.7	sub op_or {
303			$source .= <<EOF;
304			{
305			dSP;
306
307			if (!SvTRUE (TOPs))
308			{
309			--SP;
310			PUTBACK;
311			nextop = (OP *)${$op->other}L;
312			goto op_${$op->other};
313			}
314			}
315			EOF
316
317	root	1.8	out_next;
318	root	1.7	}
319
320	root	1.4	sub op_padsv {
321			my $flags = $op->flags;
322			my $target = $op->targ;
323
324			$source .= <<EOF;
325			{
326			dSP;
327			XPUSHs (PAD_SV ((PADOFFSET)$target));
328			PUTBACK;
329			EOF
330			if ($op->flags & B::OPf_MOD) {
331			if ($op->private & B::OPpLVAL_INTRO) {
332			$source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
333			} elsif ($op->private & B::OPpDEREF) {
334			my $deref = $op->private & B::OPpDEREF;
335			$source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
336			}
337			}
338			$source .= <<EOF;
339			}
340			EOF
341
342	root	1.8	out_next;
343	root	1.6	}
344
345	root	1.3	# pattern const+ (or general push1)
346			# pattern pushmark return(?)
347			# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
348
349			# pattern const method_named
350	root	1.12	sub op_method_named {
351	root	1.3	$source .= <<EOF;
352			{
353	root	1.4	static HV *last_stash;
354	root	1.11	static SV *last_cv;
355			static U32 last_sub_generation;
356	root	1.4
357			SV obj = (PL_stack_base + TOPMARK + 1);
358	root	1.3
359	root	1.11	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
360	root	1.3	{
361	root	1.4	dSP;
362			HV *stash = SvSTASH (SvRV (obj));
363	root	1.3
364	root	1.4	/* simple "polymorphic" inline cache */
365	root	1.11	if (stash == last_stash
366			&& PL_sub_generation == last_sub_generation)
367	root	1.3	{
368	root	1.11	XPUSHs (last_cv);
369	root	1.4	PUTBACK;
370	root	1.3	}
371			else
372			{
373	root	1.11	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
374	root	1.4
375	root	1.3	SPAGAIN;
376	root	1.11	last_sub_generation = PL_sub_generation;
377			last_stash = stash;
378			last_cv = TOPs;
379	root	1.3	}
380			}
381	root	1.4	else
382			{
383			/* error case usually */
384	root	1.11	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
385	root	1.4	}
386	root	1.3	}
387			EOF
388
389	root	1.8	out_next;
390	root	1.3	}
391
392	root	1.11	sub op_grepstart {
393			out_callop;
394			out_cond_jump $op->next->other;
395			out_jump_next;
396			}
397
398			*op_mapstart = \&op_grepstart;
399
400			sub op_substcont {
401			out_callop;
402			out_cond_jump $op->other->pmreplstart;
403			assert "nextop == (OP *)${$op->other->next}L";
404			$source .= " goto op_${$op->other->next};\n";
405			}
406
407			sub out_break_op {
408			my ($idx) = @_;
409
410			out_callop;
411
412			out_cond_jump $_->[$idx]
413			for reverse @loop;
414
415			$source .= " return nextop;\n";
416			}
417
418			sub xop_next {
419			out_break_op 0;
420			}
421
422			sub op_last {
423			out_break_op 1;
424			}
425
426			sub xop_redo {
427			out_break_op 2;
428			}
429
430	root	1.4	sub cv2c {
431	root	1.1	my ($cv) = @_;
432
433	root	1.11	@loop = ();
434
435	root	1.1	my %opsseen;
436			my @todo = $cv->START;
437
438			while (my $op = shift @todo) {
439			for (; $$op; $op = $op->next) {
440			last if $opsseen{$$op}++;
441			push @ops, $op;
442	root	1.11
443	root	1.1	my $name = $op->name;
444	root	1.11	my $class = B::class $op;
445
446			if ($class eq "LOGOP") {
447			unshift @todo, $op->other; # unshift vs. push saves jumps
448			} elsif ($class eq "PMOP") {
449			unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
450			} elsif ($class eq "LOOP") {
451			push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
452	root	1.1	}
453			}
454			}
455
456	root	1.4	local $source = <<EOF;
457			OP *%%%FUNC%%% (pTHX)
458			{
459			register OP nextop = (OP )${$ops[0]}L;
460			EOF
461	root	1.2
462	root	1.8	while (@ops) {
463			$op = shift @ops;
464			$op_name = $op->name;
465	root	1.2
466	root	1.8	$source .= "op_$$op: /* $op_name */\n";
467			#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
468	root	1.4	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
469
470	root	1.11	$source .= " PERL_ASYNC_CHECK ();\n"
471			unless exists $flag{noasync}{$op_name};
472	root	1.2
473	root	1.8	if (my $can = __PACKAGE__->can ("op_$op_name")) {
474	root	1.11	# handcrafted replacement
475	root	1.2	$can->($op);
476	root	1.11
477	root	1.8	} elsif (exists $flag{unsafe}{$op_name}) {
478	root	1.11	# unsafe, return to interpreter
479			assert "nextop == (OP *)$$op";
480	root	1.9	$source .= " return nextop;\n";
481	root	1.11
482			} elsif ("LOGOP" eq B::class $op) {
483			# logical operation with optionaö branch
484			out_callop;
485			out_cond_jump $op->other;
486			out_jump_next;
487
488			} elsif ("PMOP" eq B::class $op) {
489			# regex-thingy
490			out_callop;
491			out_cond_jump $op->pmreplroot if ${$op->pmreplroot};
492			out_jump_next;
493
494	root	1.2	} else {
495	root	1.11	# normal operator, linear execution
496	root	1.8	out_linear;
497	root	1.2	}
498	root	1.1	}
499	root	1.2
500	root	1.11	$op_name = "func exit"; assert (0);
501
502			$source .= <<EOF;
503			op_0:
504			return 0;
505			}
506			EOF
507	root	1.4	#warn $source;
508	root	1.2
509	root	1.4	$source
510			}
511
512			sub source2ptr {
513			my ($source) = @_;
514
515			my $md5 = Digest::MD5::md5_hex $source;
516			$source =~ s/%%%FUNC%%%/Faster_$md5/;
517
518			my $stem = "/tmp/$md5";
519
520			unless (-e "$stem$_so") {
521			open FILE, ">:raw", "$stem.c";
522	root	1.11	print FILE <<EOF;
523			#define PERL_NO_GET_CONTEXT
524
525			#include <assert.h>
526
527			#include "EXTERN.h"
528			#include "perl.h"
529			#include "XSUB.h"
530
531			#define RUNOPS_TILL(op) \\
532			while (nextop != (op)) \\
533			{ \\
534			PERL_ASYNC_CHECK (); \\
535			PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
536			}
537
538			EOF
539	root	1.4	print FILE $source;
540			close FILE;
541			system "$COMPILE -o $stem$_o $stem.c";
542			system "$LINK -o $stem$_so $stem$_o $LIBS";
543			}
544
545			# warn $source;
546			my $so = DynaLoader::dl_load_file "$stem$_so"
547			or die "$stem$_so: $!";
548
549			DynaLoader::dl_find_symbol $so, "Faster_$md5"
550			or die "Faster_$md5: $!"
551			}
552
553			sub entersub {
554			my ($cv) = @_;
555
556	root	1.11	# always compile the whole stash
557			# my @stash = $cv->STASH->ARRAY;
558			# warn join ":", @stash;
559			# exit;
560
561	root	1.4	eval {
562			my $source = cv2c $cv;
563
564	root	1.11	my $ptr = source2ptr $source;
565	root	1.4
566	root	1.11	patch_cv $cv, $ptr;
567	root	1.4	};
568
569			warn $@ if $@;
570	root	1.1	}
571
572			hook_entersub;
573
574			1;
575
576			=back
577
578	root	1.11	=head1 BUGS/LIMITATIONS
579
580			Perl will check much less often for asynchronous signals in
581			Faster-compiled code. It tries to check on every function call, loop
582			iteration and every I/O operator, though.
583
584			The following things will disable Faster. If you manage to enable them at
585			runtime, bad things will happen.
586
587			enabled tainting
588			enabled debugging
589
590			This will dramatically reduce Faster's performance:
591
592			threads (but you don't care about speed if you use threads anyway)
593
594			These constructs will force the use of the interpreter as soon as they are
595			being executed, for the rest of the currently executed:
596	root	1.2
597	root	1.11	.., ... (flipflop operators)
598			goto
599			next, redo (but not well-behaved last's)
600			eval
601			require
602			any use of formats
603	root	1.2
604	root	1.1	=head1 AUTHOR
605
606			Marc Lehmann <schmorp@schmorp.de>
607			http://home.schmorp.de/
608
609			=cut
610