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 *
#	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	root	1.19	Right now, Faster will leave lots of F<.c>, F<.o> and F<*.so> files in
31	root	1.18	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	root	1.19	#use Digest::MD5 ();
44	root	1.4	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.21	my $opt_assert = $ENV{FASTER_DEBUG};
64			my $verbose = $ENV{FASTER_VERBOSE}+0;
65	root	1.11
66	root	1.1	our $source;
67
68	root	1.18	our @ops;
69			our $op;
70			our $op_name;
71			our @op_loop;
72			our %op_regcomp;
73	root	1.8
74	root	1.20	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	root	1.2
82	root	1.20	# 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	root	1.2
114	root	1.11	my %callop = (
115			entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
116			mapstart => "Perl_pp_grepstart (aTHX)",
117			);
118
119	root	1.8	sub callop {
120	root	1.11	$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	root	1.8	}
132
133	root	1.18	sub out_cond_jump {
134			$source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
135			}
136
137	root	1.11	sub out_jump_next {
138	root	1.18	out_cond_jump $op_regcomp{$$op}
139			if $op_regcomp{$$op};
140
141	root	1.11	assert "nextop == (OP *)${$op->next}";
142			$source .= " goto op_${$op->next};\n";
143	root	1.2	}
144
145	root	1.9	sub out_next {
146			$source .= " nextop = (OP *)${$op->next}L;\n";
147
148	root	1.11	out_jump_next;
149	root	1.9	}
150
151	root	1.8	sub out_linear {
152	root	1.11	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	root	1.4	}
161
162	root	1.11	*op_require = \&op_entersub;
163
164	root	1.2	sub op_nextstate {
165	root	1.4	$source .= " PL_curcop = (COP *)nextop;\n";
166	root	1.2	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
167			$source .= " FREETMPS;\n";
168
169	root	1.8	out_next;
170	root	1.2	}
171
172	root	1.3	sub op_pushmark {
173			$source .= " PUSHMARK (PL_stack_sp);\n";
174
175	root	1.8	out_next;
176	root	1.3	}
177
178	root	1.13	if ($Config{useithreads} ne "define") {
179	root	1.8	# 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	root	1.2
219	root	1.8	*op_gvsv = sub {
220			$source .= " {\n";
221			$source .= " dSP;\n";
222			$source .= " EXTEND (SP, 1);\n";
223	root	1.2
224	root	1.8	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	root	1.2	}
236
237	root	1.12	# 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	root	1.3
251	root	1.8	out_next;
252	root	1.3	}
253
254	root	1.4	sub op_and {
255			$source .= <<EOF;
256			{
257			dSP;
258	root	1.5
259	root	1.4	if (SvTRUE (TOPs))
260			{
261			--SP;
262			PUTBACK;
263			nextop = (OP *)${$op->other}L;
264			goto op_${$op->other};
265			}
266			}
267			EOF
268	root	1.5
269	root	1.8	out_next;
270	root	1.4	}
271
272	root	1.7	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	root	1.8	out_next;
288	root	1.7	}
289
290	root	1.4	sub op_padsv {
291			my $flags = $op->flags;
292	root	1.21	my $targ = $op->targ;
293	root	1.4
294			$source .= <<EOF;
295			{
296			dSP;
297	root	1.21	XPUSHs (PAD_SV ((PADOFFSET)$targ));
298	root	1.4	PUTBACK;
299			EOF
300			if ($op->flags & B::OPf_MOD) {
301			if ($op->private & B::OPpLVAL_INTRO) {
302	root	1.21	$source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$targ));\n";
303	root	1.4	} elsif ($op->private & B::OPpDEREF) {
304			my $deref = $op->private & B::OPpDEREF;
305	root	1.21	$source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$targ), $deref);\n";
306	root	1.4	}
307			}
308			$source .= <<EOF;
309			}
310			EOF
311
312	root	1.8	out_next;
313	root	1.6	}
314
315	root	1.3	# 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	root	1.12	sub op_method_named {
321	root	1.3	$source .= <<EOF;
322			{
323	root	1.4	static HV *last_stash;
324	root	1.11	static SV *last_cv;
325			static U32 last_sub_generation;
326	root	1.4
327			SV obj = (PL_stack_base + TOPMARK + 1);
328	root	1.3
329	root	1.11	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
330	root	1.3	{
331	root	1.4	dSP;
332			HV *stash = SvSTASH (SvRV (obj));
333	root	1.3
334	root	1.4	/* simple "polymorphic" inline cache */
335	root	1.11	if (stash == last_stash
336			&& PL_sub_generation == last_sub_generation)
337	root	1.3	{
338	root	1.11	XPUSHs (last_cv);
339	root	1.4	PUTBACK;
340	root	1.3	}
341			else
342			{
343	root	1.11	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
344	root	1.4
345	root	1.3	SPAGAIN;
346	root	1.11	last_sub_generation = PL_sub_generation;
347			last_stash = stash;
348			last_cv = TOPs;
349	root	1.3	}
350			}
351	root	1.4	else
352			{
353			/* error case usually */
354	root	1.11	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
355	root	1.4	}
356	root	1.3	}
357			EOF
358
359	root	1.8	out_next;
360	root	1.3	}
361
362	root	1.11	sub op_grepstart {
363			out_callop;
364	root	1.14	$op = $op->next;
365			out_cond_jump $op->other;
366	root	1.11	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	root	1.18	for reverse @op_loop;
385	root	1.11
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	root	1.4	sub cv2c {
402	root	1.1	my ($cv) = @_;
403
404	root	1.18	local @ops;
405			local @op_loop;
406			local %op_regcomp;
407	root	1.11
408	root	1.1	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	root	1.11
416	root	1.1	my $name = $op->name;
417	root	1.11	my $class = B::class $op;
418
419			if ($class eq "LOGOP") {
420			unshift @todo, $op->other; # unshift vs. push saves jumps
421	root	1.18
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	root	1.11	} elsif ($class eq "PMOP") {
427			unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
428	root	1.18
429	root	1.11	} elsif ($class eq "LOOP") {
430	root	1.18	push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
431			push @todo, $op->nextop, $op->lastop->next, $op->redoop->next;
432	root	1.1	}
433			}
434			}
435
436	root	1.4	local $source = <<EOF;
437			OP *%%%FUNC%%% (pTHX)
438			{
439			register OP nextop = (OP )${$ops[0]}L;
440			EOF
441	root	1.2
442	root	1.8	while (@ops) {
443			$op = shift @ops;
444			$op_name = $op->name;
445	root	1.2
446	root	1.8	$source .= "op_$$op: /* $op_name */\n";
447			#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
448	root	1.4	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
449
450	root	1.11	$source .= " PERL_ASYNC_CHECK ();\n"
451	root	1.20	unless exists $f_noasync{$op_name};
452	root	1.2
453	root	1.8	if (my $can = __PACKAGE__->can ("op_$op_name")) {
454	root	1.11	# handcrafted replacement
455	root	1.2	$can->($op);
456	root	1.11
457	root	1.20	} elsif (exists $f_unsafe{$op_name}) {
458	root	1.11	# unsafe, return to interpreter
459			assert "nextop == (OP *)$$op";
460	root	1.9	$source .= " return nextop;\n";
461	root	1.11
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	root	1.2	} else {
475	root	1.11	# normal operator, linear execution
476	root	1.8	out_linear;
477	root	1.2	}
478	root	1.1	}
479	root	1.2
480	root	1.11	$op_name = "func exit"; assert (0);
481
482			$source .= <<EOF;
483			op_0:
484			return 0;
485			}
486			EOF
487	root	1.4	#warn $source;
488	root	1.2
489	root	1.4	$source
490			}
491
492	root	1.19	my $uid = "aaaaaaa0";
493
494	root	1.4	sub source2ptr {
495	root	1.19	my (@source) = @_;
496	root	1.4
497	root	1.19	my $stem = "/tmp/Faster-$$-" . $uid++;
498	root	1.4
499	root	1.19	open FILE, ">:raw", "$stem.c";
500			print FILE <<EOF;
501	root	1.11	#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	root	1.19	while (nextop != (op)) \\
511			{ \\
512			PERL_ASYNC_CHECK (); \\
513			PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
514			}
515	root	1.11
516			EOF
517	root	1.19	for (@source) {
518			my $func = $uid++;
519			$_ =~ s/%%%FUNC%%%/$func/g;
520			print FILE $_;
521			$_ = $func;
522	root	1.4	}
523
524	root	1.19	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	root	1.4	my $so = DynaLoader::dl_load_file "$stem$_so"
531			or die "$stem$_so: $!";
532
533	root	1.19	#unlink "$stem$_so";
534
535			map +(DynaLoader::dl_find_symbol $so, $_), @source
536	root	1.4	}
537
538	root	1.19	my %ignore;
539
540	root	1.4	sub entersub {
541			my ($cv) = @_;
542
543	root	1.19	my $pkg = $cv->STASH->NAME;
544
545			return if $ignore{$pkg};
546
547	root	1.21	warn "compiling ", $cv->STASH->NAME, "\n"
548			if $verbose;
549	root	1.11
550	root	1.4	eval {
551	root	1.19	my @cv;
552			my @cv_source;
553	root	1.4
554	root	1.19	# 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	root	1.4
572	root	1.19	for (0 .. $#cv) {
573			patch_cv $cv[$_], $ptr[$_];
574			}
575	root	1.4	};
576
577	root	1.19	if ($@) {
578			$ignore{$pkg}++;
579			warn $@;
580			}
581	root	1.1	}
582
583			hook_entersub;
584
585			1;
586
587			=back
588
589	root	1.21	=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	root	1.11	=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	root	1.19	runtime, bad things will happen. Enabling them at startup will be fine,
628			though.
629	root	1.11
630			enabled tainting
631			enabled debugging
632
633	root	1.19	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	root	1.11
636	root	1.19	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	root	1.11
639			goto
640			next, redo (but not well-behaved last's)
641			eval
642			require
643			any use of formats
644	root	1.19	.., ... (flipflop operators)
645	root	1.2
646	root	1.1	=head1 AUTHOR
647
648			Marc Lehmann <schmorp@schmorp.de>
649			http://home.schmorp.de/
650
651			=cut
652