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 Digest::MD5 ();
use Storable ();

BEGIN {
   our $VERSION = '0.01';

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

my $CACHEDIR = $ENV{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;

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
   my $meta = eval { Storable::retrieve "$CACHEDIR/meta" } || { 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";
      #d#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: $!";
   }

   Storable::nstore $meta, "$CACHEDIR/meta";
   # UNLOCK
}

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;

      # 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.

=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 CORRECTLY, SHARING BEETWEEN INSTANCES IS IMPOSSIBLE

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