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;

no warnings;

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 $insn;
our $op;
our $op_name;
our @op_loop;
our %op_regcomp;

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

# ops with known stack extend behaviour
# the values given are maximum values
my %extend = (
  pushmark  => 0,
  nextstate => 0, # might reduce the stack
  unstack   => 0,
  enter     => 0,

  stringify => 0,
  not       => 0,
  and       => 0,
  or        => 0,
  gvsv      => 0,
  rv2gv     => 0,
  preinc    => 0,
  predec    => 0,
  postinc   => 0,
  postdec   => 0,
  aelem     => 0,
  helem     => 0,
  qr        => 1, #???
  pushre    => 1,
  gv        => 1,
  aelemfast => 1,
  aelem     => 0,
  padsv     => 1,
  const     => 1,
  pop       => 1,
  shift     => 1,
  eq        => -1,
  ne        => -1,
  gt        => -1,
  lt        => -1,
  ge        => -1,
  lt        => -1,
  cond_expr => -1,
  add       => -1,
  subtract  => -1,
  multiply  => -1,
  divide    => -1,
  aassign   => 0,
  sassign   => -2,
  method    => 0,
  method_named => 1,
);

# ops that do not need an ASYNC_CHECK
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 method_named bless
   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; PUSHs ((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 .= "    PUSHs (sv);\n";
      $source .= "    PUTBACK;\n";
      $source .= "  }\n";

      out_next;
   };

   *op_gvsv = sub {
      $source .= "  {\n";
      $source .= "    dSP;\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 $padofs = "(PADOFFSET)" . $op->targ;

   #d#TODO: why does our version break
   # breaks gce with can't coerce array....
   if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {#d#
      return out_linear;#d#
   }#d#

   $source .= <<EOF;
  {
    dSP;
    SV *sv = PAD_SVl ($padofs);
EOF

   if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
      $source .= "    SAVECLEARSV (PAD_SVl ($padofs));\n";
      $ops[0]{pre_padsv_lval_intro}++ if @ops;#d#
   }
         
   $source .= <<EOF;
    PUSHs (sv);
    PUTBACK;
EOF

   if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
      $source .= "    vivify_ref (sv, $flags & OPpDEREF);\n";
   }
   $source .= "  }\n";

   out_next;
}

sub op_sassign {
  $source .= <<EOF;
  {
    dSP;
    dPOPTOPssrl;
EOF
   $source .= "    SV *temp = left; left = right; right = temp;\n"
      if $op->private & B::OPpASSIGN_BACKWARDS;

   if ($insn->{pre_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
      # simple assignment - the target exists, but is basically undef
      $source .= "    SvSetSV (right, left);\n";
   } else {
      $source .= "    SvSetMagicSV (right, left);\n";
   }

   $source .= <<EOF;
    SETs (right);
    PUTBACK;
  }
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)
          {
            PUSHs (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;
   my %op_target;

   while (my $op = shift @todo) {
      for (; $$op; $op = $op->next) {
         last if $opsseen{$$op}++;

         my $name = $op->name;
         my $class = B::class $op;

         my $insn = { op => $op };

         push @ops, $insn;

         if (exists $extend{$name}) {
            my $extend = $extend{$name};
            $extend = $extend->($op) if ref $extend;
            $insn->{extend} = $extend if defined $extend;
         }

         push @todo, $op->next;

         if ($class eq "LOGOP") {
            push @todo, $op->other;
            $op_target{${$op->other}}++;

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

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

         } elsif ($class eq "LOOP") {
            my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);

            push @op_loop, \@targ;
            push @todo, @targ;

            $op_target{$$_}++ for @targ;
         } elsif ($class eq "COP") {
            $insn->{bblock}++ if defined $op->label;
         }
      }
   }

   $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;

   local $source = <<EOF;
OP *%%%FUNC%%% (pTHX)
{
  register OP *nextop = (OP *)${$ops[0]->{op}}L;
EOF

   while (@ops) {
      $insn = shift @ops;

      $op = $insn->{op};
      $op_name = $op->name;

      my $class = B::class $op;

      $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
      $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

         if ($insn->{extend} > 0) {
            # coalesce EXTENDs
            # TODO: properly take negative preceeding and following EXTENDs into account
            for my $i (@ops) {
               last if exists $i->{bblock};
               last unless exists $i->{extend};
               my $extend = delete $i->{extend};
               $insn->{extend} += $extend if $extend > 0;
            }

            $source .= "  { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
               if $insn->{extend} > 0;
         }

         $can->($op);

      } elsif (exists $f_unsafe{$op_name}) {
         # unsafe, return to interpreter
         assert "nextop == (OP *)$$op";
         $source .= "  return nextop;\n";

      } elsif ("LOGOP" eq $class) {
         # logical operation with optional branch
         out_callop;
         out_cond_jump $op->other;
         out_jump_next;

      } elsif ("PMOP" eq $class) {
         # regex-thingy
         out_callop;
         out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$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
#define PERL_CORE

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