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
your F<$FASTER_CACHEDIR> (by default F<$HOME/.perl-faster-cache>), 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 DynaLoader ();
use Digest::MD5 ();
use Storable ();
use Fcntl ();

BEGIN {
   our $VERSION = '0.01';

   require XSLoader;
   XSLoader::load __PACKAGE__, $VERSION;
}

my $CACHEDIR =
   $ENV{FASTER_CACHE}
   || (exists $ENV{HOME} && "$ENV{HOME}/.perl-faster-cache")
   || do {
      require File::Temp;
      File::Temp::tempdir (CLEANUP => 1)
   };

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;

warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;

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_op->op_ppaddr) (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";

      $ops[0]{follows_const}++ if @ops;#d#

      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;

   $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]{follows_padsv_lval_intro}++ if @ops;#d#
   }
         
   $source .= <<EOF;
    PUSHs (sv);
    PUTBACK;
EOF

   if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
      $source .= "    if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & 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->{follows_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 gv rv2av pushmark padsv+o.ä. aassign

sub op_method_named {
   if ($insn->{follows_const}) {
      $source .= <<EOF;
  {
    dSP;
    static SV *last_cv;
    static U32 last_sub_generation;

    /* simple "polymorphic" inline cache */
    if (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_cv             = TOPs;
      }
  }
EOF
   } else {
      $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";
my %so;

sub func2ptr {
   my (@func) = @_;

   #LOCK
   mkdir $CACHEDIR, 0777;
   sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR | &Fcntl::O_CREAT, 0666
      or die "$$CACHEDIR/meta: $!";
   binmode $meta_fh, ":raw:perlio";
   fcntl_lock fileno $meta_fh
      or die "$CACHEDIR/meta: $!";

   my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };

   for my $f (@func) {
      $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
      $f->{so}   = $meta->{$f->{func}};
   }

   if (grep !$_->{so}, @func) {
      my $stem;
      
      do {
         $stem = "$CACHEDIR/$$-" . $uid++;
      } while -e "$stem$_so";

      open my $fh, ">:raw", "$stem.c";
      print $fh <<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 my $f (grep !$_->{so}, @func) {
         next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others

         warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
         my $source = $f->{source};
         $source =~ s/%%%FUNC%%%/$f->{func}/g;
         print $fh $source;
         $meta->{$f->{func}} = $f->{so} = $stem;
      }

      close $fh;
      system "$COMPILE -o $stem$_o $stem.c";
      unlink "$stem.c";
      system "$LINK -o $stem$_so $stem$_o $LIBS";
      unlink "$stem$_o";
   }

   for my $f (@func) {
      my $stem = $f->{so};

      my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
         or die "$stem$_so: $!";

      #unlink "$stem$_so";

      $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
         or die "$f->{func} not found in $stem$_so: $!";
   }

   seek $meta_fh, 0,  0 or die "$CACHEDIR/meta: $!";
   Storable::nstore_fd $meta, $meta_fh;
   truncate $meta_fh, tell $meta_fh;

   # UNLOCK (by closing $meta_fh)
}

my %ignore;

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

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

   return if $ignore{$pkg};

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

   eval {
      my @func;

      push @func, {
         cv     => $cv,
         name   => "<>",
         source => cv2c $cv,
      };

      # 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 @func, {
               cv     => $cv,
               name   => $k,
               source => cv2c $cv,
            };
         }
      }

      func2ptr @func;

      for my $f (@func) {
         patch_cv $f->{cv}, $f->{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, C<3>
outputs the cache directory and C<10> outputs information on which perl
function is compiled into which shared object.

=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

Set a persistent cache directory that caches compiled code fragments. The
default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
directory otherwise.

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