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 ();
use File::Temp ();

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