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

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

# 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.12
Committed:	Fri Mar 10 18:39:26 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.11:	+15 -4 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	root	1.12	match noasync
70	root	1.11
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.12	# does kill Crossfire/res2pm
264			sub op_stringify {
265			my $targ = $op->targ;
266
267			$source .= <<EOF;
268			{
269			dSP;
270			SV *targ = PAD_SV ((PADOFFSET)$targ);
271			sv_copypv (TARG, TOPs);
272			SETTARG;
273			PUTBACK;
274			}
275			EOF
276	root	1.3
277	root	1.8	out_next;
278	root	1.3	}
279
280	root	1.4	sub op_and {
281			$source .= <<EOF;
282			{
283			dSP;
284	root	1.5
285	root	1.4	if (SvTRUE (TOPs))
286			{
287			--SP;
288			PUTBACK;
289			nextop = (OP *)${$op->other}L;
290			goto op_${$op->other};
291			}
292			}
293			EOF
294	root	1.5
295	root	1.8	out_next;
296	root	1.4	}
297
298	root	1.7	sub op_or {
299			$source .= <<EOF;
300			{
301			dSP;
302
303			if (!SvTRUE (TOPs))
304			{
305			--SP;
306			PUTBACK;
307			nextop = (OP *)${$op->other}L;
308			goto op_${$op->other};
309			}
310			}
311			EOF
312
313	root	1.8	out_next;
314	root	1.7	}
315
316	root	1.4	sub op_padsv {
317			my $flags = $op->flags;
318			my $target = $op->targ;
319
320			$source .= <<EOF;
321			{
322			dSP;
323			XPUSHs (PAD_SV ((PADOFFSET)$target));
324			PUTBACK;
325			EOF
326			if ($op->flags & B::OPf_MOD) {
327			if ($op->private & B::OPpLVAL_INTRO) {
328			$source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
329			} elsif ($op->private & B::OPpDEREF) {
330			my $deref = $op->private & B::OPpDEREF;
331			$source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
332			}
333			}
334			$source .= <<EOF;
335			}
336			EOF
337
338	root	1.8	out_next;
339	root	1.6	}
340
341	root	1.3	# pattern const+ (or general push1)
342			# pattern pushmark return(?)
343			# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
344
345			# pattern const method_named
346	root	1.12	sub op_method_named {
347	root	1.3	$source .= <<EOF;
348			{
349	root	1.4	static HV *last_stash;
350	root	1.11	static SV *last_cv;
351			static U32 last_sub_generation;
352	root	1.4
353			SV obj = (PL_stack_base + TOPMARK + 1);
354	root	1.3
355	root	1.11	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
356	root	1.3	{
357	root	1.4	dSP;
358			HV *stash = SvSTASH (SvRV (obj));
359	root	1.3
360	root	1.4	/* simple "polymorphic" inline cache */
361	root	1.11	if (stash == last_stash
362			&& PL_sub_generation == last_sub_generation)
363	root	1.3	{
364	root	1.11	XPUSHs (last_cv);
365	root	1.4	PUTBACK;
366	root	1.3	}
367			else
368			{
369	root	1.11	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
370	root	1.4
371	root	1.3	SPAGAIN;
372	root	1.11	last_sub_generation = PL_sub_generation;
373			last_stash = stash;
374			last_cv = TOPs;
375	root	1.3	}
376			}
377	root	1.4	else
378			{
379			/* error case usually */
380	root	1.11	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
381	root	1.4	}
382	root	1.3	}
383			EOF
384
385	root	1.8	out_next;
386	root	1.3	}
387
388	root	1.11	sub op_grepstart {
389			out_callop;
390			out_cond_jump $op->next->other;
391			out_jump_next;
392			}
393
394			*op_mapstart = \&op_grepstart;
395
396			sub op_substcont {
397			out_callop;
398			out_cond_jump $op->other->pmreplstart;
399			assert "nextop == (OP *)${$op->other->next}L";
400			$source .= " goto op_${$op->other->next};\n";
401			}
402
403			sub out_break_op {
404			my ($idx) = @_;
405
406			out_callop;
407
408			out_cond_jump $_->[$idx]
409			for reverse @loop;
410
411			$source .= " return nextop;\n";
412			}
413
414			sub xop_next {
415			out_break_op 0;
416			}
417
418			sub op_last {
419			out_break_op 1;
420			}
421
422			sub xop_redo {
423			out_break_op 2;
424			}
425
426	root	1.4	sub cv2c {
427	root	1.1	my ($cv) = @_;
428
429	root	1.11	@loop = ();
430
431	root	1.1	my %opsseen;
432			my @todo = $cv->START;
433
434			while (my $op = shift @todo) {
435			for (; $$op; $op = $op->next) {
436			last if $opsseen{$$op}++;
437			push @ops, $op;
438	root	1.11
439	root	1.1	my $name = $op->name;
440	root	1.11	my $class = B::class $op;
441
442			if ($class eq "LOGOP") {
443			unshift @todo, $op->other; # unshift vs. push saves jumps
444			} elsif ($class eq "PMOP") {
445			unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
446			} elsif ($class eq "LOOP") {
447			push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
448	root	1.1	}
449			}
450			}
451
452	root	1.4	local $source = <<EOF;
453			OP *%%%FUNC%%% (pTHX)
454			{
455			register OP nextop = (OP )${$ops[0]}L;
456			EOF
457	root	1.2
458	root	1.8	while (@ops) {
459			$op = shift @ops;
460			$op_name = $op->name;
461	root	1.2
462	root	1.8	$source .= "op_$$op: /* $op_name */\n";
463			#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
464	root	1.4	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
465
466	root	1.11	$source .= " PERL_ASYNC_CHECK ();\n"
467			unless exists $flag{noasync}{$op_name};
468	root	1.2
469	root	1.8	if (my $can = __PACKAGE__->can ("op_$op_name")) {
470	root	1.11	# handcrafted replacement
471	root	1.2	$can->($op);
472	root	1.11
473	root	1.8	} elsif (exists $flag{unsafe}{$op_name}) {
474	root	1.11	# unsafe, return to interpreter
475			assert "nextop == (OP *)$$op";
476	root	1.9	$source .= " return nextop;\n";
477	root	1.11
478			} elsif ("LOGOP" eq B::class $op) {
479			# logical operation with optionaö branch
480			out_callop;
481			out_cond_jump $op->other;
482			out_jump_next;
483
484			} elsif ("PMOP" eq B::class $op) {
485			# regex-thingy
486			out_callop;
487			out_cond_jump $op->pmreplroot if ${$op->pmreplroot};
488			out_jump_next;
489
490	root	1.2	} else {
491	root	1.11	# normal operator, linear execution
492	root	1.8	out_linear;
493	root	1.2	}
494	root	1.1	}
495	root	1.2
496	root	1.11	$op_name = "func exit"; assert (0);
497
498			$source .= <<EOF;
499			op_0:
500			return 0;
501			}
502			EOF
503	root	1.4	#warn $source;
504	root	1.2
505	root	1.4	$source
506			}
507
508			sub source2ptr {
509			my ($source) = @_;
510
511			my $md5 = Digest::MD5::md5_hex $source;
512			$source =~ s/%%%FUNC%%%/Faster_$md5/;
513
514			my $stem = "/tmp/$md5";
515
516			unless (-e "$stem$_so") {
517			open FILE, ">:raw", "$stem.c";
518	root	1.11	print FILE <<EOF;
519			#define PERL_NO_GET_CONTEXT
520
521			#include <assert.h>
522
523			#include "EXTERN.h"
524			#include "perl.h"
525			#include "XSUB.h"
526
527			#define RUNOPS_TILL(op) \\
528			while (nextop != (op)) \\
529			{ \\
530			PERL_ASYNC_CHECK (); \\
531			PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
532			}
533
534			EOF
535	root	1.4	print FILE $source;
536			close FILE;
537			system "$COMPILE -o $stem$_o $stem.c";
538			system "$LINK -o $stem$_so $stem$_o $LIBS";
539			}
540
541			# warn $source;
542			my $so = DynaLoader::dl_load_file "$stem$_so"
543			or die "$stem$_so: $!";
544
545			DynaLoader::dl_find_symbol $so, "Faster_$md5"
546			or die "Faster_$md5: $!"
547			}
548
549			sub entersub {
550			my ($cv) = @_;
551
552	root	1.11	# always compile the whole stash
553			# my @stash = $cv->STASH->ARRAY;
554			# warn join ":", @stash;
555			# exit;
556
557	root	1.4	eval {
558			my $source = cv2c $cv;
559
560	root	1.11	my $ptr = source2ptr $source;
561	root	1.4
562	root	1.11	patch_cv $cv, $ptr;
563	root	1.4	};
564
565			warn $@ if $@;
566	root	1.1	}
567
568			hook_entersub;
569
570			1;
571
572			=back
573
574	root	1.11	=head1 BUGS/LIMITATIONS
575
576			Perl will check much less often for asynchronous signals in
577			Faster-compiled code. It tries to check on every function call, loop
578			iteration and every I/O operator, though.
579
580			The following things will disable Faster. If you manage to enable them at
581			runtime, bad things will happen.
582
583			enabled tainting
584			enabled debugging
585
586			This will dramatically reduce Faster's performance:
587
588			threads (but you don't care about speed if you use threads anyway)
589
590			These constructs will force the use of the interpreter as soon as they are
591			being executed, for the rest of the currently executed:
592	root	1.2
593	root	1.11	.., ... (flipflop operators)
594			goto
595			next, redo (but not well-behaved last's)
596			eval
597			require
598			any use of formats
599	root	1.2
600	root	1.1	=head1 AUTHOR
601
602			Marc Lehmann <schmorp@schmorp.de>
603			http://home.schmorp.de/
604
605			=cut
606