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 lots 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 = $ENV{FASTER_DEBUG};
my $verbose    = $ENV{FASTER_VERBOSE}+0;

our $source;

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

my %f_unsafe = map +($_ => undef), qw(
   leavesub leavesublv return
   goto last redo next
   eval flip leaveeval entertry
   formline grepstart mapstart
   substcont entereval require
);

#  pushmark     extend=0
#  padsv        extend=1
#  padav        extend=1
#  padhv        extend=1
#  padany       extend=1
#  const        extend=1

my %f_noasync = map +($_ => undef), qw(
   mapstart grepstart match entereval
   enteriter entersub leaveloop

   pushmark nextstate

   const stub unstack
   last next redo seq
   padsv padav padhv padany
   aassign sassign orassign
   rv2av rv2cv rv2gv rv2hv refgen
   gv gvsv
   add subtract multiply divide
   complement cond_expr and or not
   defined
   method_named
   preinc postinc predec postdec
   aelem aelemfast helem delete exists
   pushre subst list join split concat
   length substr stringify ord
   push pop shift unshift
   eq ne gt lt ge le
   regcomp regcreset regcmaybe
);

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 $targ = $op->targ;

   $source .= <<EOF;
  {
    dSP;
    XPUSHs (PAD_SV ((PADOFFSET)$targ));
    PUTBACK;
EOF
   if ($op->flags & B::OPf_MOD) {
      if ($op->private & B::OPpLVAL_INTRO) {
         $source .= "    SAVECLEARSV (PAD_SVl ((PADOFFSET)$targ));\n";
      } elsif ($op->private & B::OPpDEREF) {
         my $deref = $op->private & B::OPpDEREF;
         $source .= "    Perl_vivify_ref (PAD_SVl ((PADOFFSET)$targ), $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 $f_noasync{$op_name};

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

      } elsif (exists $f_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
}

my $uid = "aaaaaaa0";

sub source2ptr {
   my (@source) = @_;

   my $stem = "/tmp/Faster-$$-" . $uid++;

   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
   for (@source) {
      my $func = $uid++;
      $_ =~ s/%%%FUNC%%%/$func/g;
      print FILE $_;
      $_ = $func;
   }

   close FILE;
   system "$COMPILE -o $stem$_o $stem.c";
   #d#unlink "$stem.c";
   system "$LINK -o $stem$_so $stem$_o $LIBS";
   unlink "$stem$_o";

   my $so = DynaLoader::dl_load_file "$stem$_so"
      or die "$stem$_so: $!";

   #unlink "$stem$_so";

   map +(DynaLoader::dl_find_symbol $so, $_), @source
}

my %ignore;

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

   my $pkg = $cv->STASH->NAME;

   return if $ignore{$pkg};

   warn "compiling ", $cv->STASH->NAME, "\n"
      if $verbose;

   eval {
      my @cv;
      my @cv_source;

      # always compile the whole stash
      my %stash = $cv->STASH->ARRAY;
      while (my ($k, $v) = each %stash) {
         $v->isa (B::GV::)
            or next;

         my $cv = $v->CV;

         if ($cv->isa (B::CV::)
             && ${$cv->START}
             && $cv->START->name ne "null") {
            push @cv, $cv;
            push @cv_source, cv2c $cv;
         }
      }

      my @ptr = source2ptr @cv_source;

      for (0 .. $#cv) {
         patch_cv $cv[$_], $ptr[$_];
      }
   };

   if ($@) {
      $ignore{$pkg}++;
      warn $@;
   }
}

hook_entersub;

1;

=back

=head1 ENVIRONMENT VARIABLES

The following environment variables influence the behaviour of Faster:

=over 4

=item FASTER_VERBOSE

Faster will output more informational messages when set to values higher
than C<0>. Currently, C<1> outputs which packages are being compiled.

=item FASTER_DEBUG

Add debugging code when set to values higher than C<0>. Currently, this
adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
execution order are compatible.

=item FASTER_CACHE

NOT YET IMPLEMENTED

Set a persistent cache directory that caches compiled code
fragments. Normally, code compiled by Faster will be deleted immediately,
and every restart will recompile everything. Setting this variable to a
directory makes Faster cache the generated files for re-use.

This directory will always grow in contents, so you might need to erase it
from time to time.

=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. Enabling them at startup will be fine,
though.

 enabled tainting
 enabled debugging

Thread-enabled builds of perl will dramatically reduce Faster's
performance, but you don't care about speed if you enable threads anyway.

These constructs will force the use of the interpreter for the currently
executed function as soon as they are being encountered during execution.

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

=head1 AUTHOR

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

=cut

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