Faster/Faster.pm

=head1 NAME

Faster - do some things faster

=head1 SYNOPSIS

 use Faster;

 perl -MFaster ...

=head1 DESCRIPTION

This module implements a very simple-minded JIT. It works by more or less
translating every function it sees into a C program, compiling it and then
replacing the function by the compiled code.

As a result, startup times are immense, as every function might lead to a
full-blown compilation.

The speed improvements are also not great, you can expect 20% or so on
average, for code that runs very often.

Faster is in the early stages of development. Due to its design its
relatively safe to use (it will either work or simply slowdown the program
immensely, but rarely cause bugs).

Usage is very easy, just C<use Faster> and every function called from then
on will be compiled.

Right now, Faster will leave ltos of F<*.c>, F<*.o> and F<*.so> files in
F</tmp>, and it will even create those temporary files in an insecure
manner, so watch out.

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

our @ops;
our $op;
our $op_name;
our @op_loop;
our %op_regcomp;

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
   orassign     noasync
   regcomp      noasync
   regcreset    noasync
   regcmaybe    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_cond_jump {
   $source .= "  if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
}

sub out_jump_next {
   out_cond_jump $op_regcomp{$$op}
      if $op_regcomp{$$op};

   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 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;
   $op = $op->next;
   out_cond_jump $op->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 @op_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) = @_;

   local @ops;
   local @op_loop;
   local %op_regcomp;

   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

            # regcomp/o patches ops at runtime, lets expect that
            $op_regcomp{${$op->first}} = $op->next
               if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP;

         } elsif ($class eq "PMOP") {
            unshift @todo, $op->pmreplstart if ${$op->pmreplstart};

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