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

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 todo#whyisitunsafe? unsafe

   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 (0 && $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;
   };
}

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

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