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