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_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 .= "    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";

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.26
Committed:	Sat Mar 11 18:13:35 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.25:	+32 -13 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	root	1.26	entersub => "(PL_op->op_ppaddr) (aTHX)",
161	root	1.11	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	root	1.26	$ops[0]{follows_const}++ if @ops;#d#
230
231	root	1.8	out_next;
232			};
233
234			*op_gv = \&op_const;
235
236			*op_aelemfast = sub {
237			my $targ = $op->targ;
238			my $private = $op->private;
239
240			$source .= " {\n";
241
242			if ($op->flags & B::OPf_SPECIAL) {
243			$source .= " AV av = (AV)PAD_SV((PADOFFSET)$targ);\n";
244			} else {
245			$source .= " AV av = GvAV ((GV )${$op->sv}L);\n";
246			}
247
248			if ($op->flags & B::OPf_MOD) {
249			$source .= " SV sv = av_fetch (av, $private, 1);\n";
250			} else {
251			$source .= " SV *svp = av_fetch (av, $private, 0); SV sv = svp ? *svp : &PL_sv_undef;\n";
252			}
253
254			if (!($op->flags & B::OPf_MOD)) {
255			$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
256			}
257
258			$source .= " dSP;\n";
259	root	1.24	$source .= " PUSHs (sv);\n";
260	root	1.8	$source .= " PUTBACK;\n";
261			$source .= " }\n";
262
263			out_next;
264			};
265	root	1.2
266	root	1.8	*op_gvsv = sub {
267			$source .= " {\n";
268			$source .= " dSP;\n";
269	root	1.2
270	root	1.8	if ($op->private & B::OPpLVAL_INTRO) {
271			$source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
272			} else {
273			$source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
274			}
275
276			$source .= " PUTBACK;\n";
277			$source .= " }\n";
278
279			out_next;
280			};
281	root	1.2	}
282
283	root	1.12	# does kill Crossfire/res2pm
284			sub op_stringify {
285			my $targ = $op->targ;
286
287			$source .= <<EOF;
288			{
289			dSP;
290			SV *targ = PAD_SV ((PADOFFSET)$targ);
291			sv_copypv (TARG, TOPs);
292			SETTARG;
293			PUTBACK;
294			}
295			EOF
296	root	1.3
297	root	1.8	out_next;
298	root	1.3	}
299
300	root	1.4	sub op_and {
301			$source .= <<EOF;
302			{
303			dSP;
304	root	1.5
305	root	1.4	if (SvTRUE (TOPs))
306			{
307			--SP;
308			PUTBACK;
309			nextop = (OP *)${$op->other}L;
310			goto op_${$op->other};
311			}
312			}
313			EOF
314	root	1.5
315	root	1.8	out_next;
316	root	1.4	}
317
318	root	1.7	sub op_or {
319			$source .= <<EOF;
320			{
321			dSP;
322
323			if (!SvTRUE (TOPs))
324			{
325			--SP;
326			PUTBACK;
327			nextop = (OP *)${$op->other}L;
328			goto op_${$op->other};
329			}
330			}
331			EOF
332
333	root	1.8	out_next;
334	root	1.7	}
335
336	root	1.4	sub op_padsv {
337			my $flags = $op->flags;
338	root	1.24	my $padofs = "(PADOFFSET)" . $op->targ;
339
340	root	1.4	$source .= <<EOF;
341			{
342			dSP;
343	root	1.24	SV *sv = PAD_SVl ($padofs);
344			EOF
345
346			if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
347			$source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
348	root	1.26	$ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
349	root	1.24	}
350
351			$source .= <<EOF;
352			PUSHs (sv);
353	root	1.4	PUTBACK;
354			EOF
355	root	1.24
356			if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
357	root	1.26	$source .= " vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
358	root	1.24	}
359			$source .= " }\n";
360
361			out_next;
362			}
363
364			sub op_sassign {
365			$source .= <<EOF;
366			{
367			dSP;
368			dPOPTOPssrl;
369			EOF
370			$source .= " SV *temp = left; left = right; right = temp;\n"
371			if $op->private & B::OPpASSIGN_BACKWARDS;
372
373	root	1.26	if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
374	root	1.24	# simple assignment - the target exists, but is basically undef
375			$source .= " SvSetSV (right, left);\n";
376			} else {
377			$source .= " SvSetMagicSV (right, left);\n";
378	root	1.4	}
379	root	1.24
380	root	1.4	$source .= <<EOF;
381	root	1.24	SETs (right);
382			PUTBACK;
383	root	1.4	}
384			EOF
385
386	root	1.24	out_next;
387	root	1.6	}
388
389	root	1.3	# pattern const+ (or general push1)
390			# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
391
392	root	1.12	sub op_method_named {
393	root	1.26	if ($insn->{follows_const}) {
394			$source .= <<EOF;
395			{
396			dSP;
397			static SV *last_cv;
398			static U32 last_sub_generation;
399
400			/* simple "polymorphic" inline cache */
401			if (PL_sub_generation == last_sub_generation)
402			{
403			PUSHs (last_cv);
404			PUTBACK;
405			}
406			else
407			{
408			PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
409
410			SPAGAIN;
411			last_sub_generation = PL_sub_generation;
412			last_cv = TOPs;
413			}
414			}
415			EOF
416			} else {
417			$source .= <<EOF;
418	root	1.3	{
419	root	1.4	static HV *last_stash;
420	root	1.11	static SV *last_cv;
421			static U32 last_sub_generation;
422	root	1.4
423			SV obj = (PL_stack_base + TOPMARK + 1);
424	root	1.3
425	root	1.11	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
426	root	1.3	{
427	root	1.4	dSP;
428			HV *stash = SvSTASH (SvRV (obj));
429	root	1.3
430	root	1.4	/* simple "polymorphic" inline cache */
431	root	1.11	if (stash == last_stash
432			&& PL_sub_generation == last_sub_generation)
433	root	1.3	{
434	root	1.24	PUSHs (last_cv);
435	root	1.4	PUTBACK;
436	root	1.3	}
437			else
438			{
439	root	1.11	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
440	root	1.4
441	root	1.3	SPAGAIN;
442	root	1.11	last_sub_generation = PL_sub_generation;
443			last_stash = stash;
444			last_cv = TOPs;
445	root	1.3	}
446			}
447	root	1.4	else
448			{
449			/* error case usually */
450	root	1.11	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
451	root	1.4	}
452	root	1.3	}
453			EOF
454	root	1.26	}
455	root	1.3
456	root	1.8	out_next;
457	root	1.3	}
458
459	root	1.11	sub op_grepstart {
460			out_callop;
461	root	1.14	$op = $op->next;
462			out_cond_jump $op->other;
463	root	1.11	out_jump_next;
464			}
465
466			*op_mapstart = \&op_grepstart;
467
468			sub op_substcont {
469			out_callop;
470			out_cond_jump $op->other->pmreplstart;
471			assert "nextop == (OP *)${$op->other->next}L";
472			$source .= " goto op_${$op->other->next};\n";
473			}
474
475			sub out_break_op {
476			my ($idx) = @_;
477
478			out_callop;
479
480			out_cond_jump $_->[$idx]
481	root	1.18	for reverse @op_loop;
482	root	1.11
483			$source .= " return nextop;\n";
484			}
485
486			sub xop_next {
487			out_break_op 0;
488			}
489
490			sub op_last {
491			out_break_op 1;
492			}
493
494			sub xop_redo {
495			out_break_op 2;
496			}
497
498	root	1.4	sub cv2c {
499	root	1.1	my ($cv) = @_;
500
501	root	1.18	local @ops;
502			local @op_loop;
503			local %op_regcomp;
504	root	1.11
505	root	1.1	my %opsseen;
506			my @todo = $cv->START;
507	root	1.24	my %op_target;
508	root	1.1
509			while (my $op = shift @todo) {
510			for (; $$op; $op = $op->next) {
511			last if $opsseen{$$op}++;
512	root	1.11
513	root	1.1	my $name = $op->name;
514	root	1.11	my $class = B::class $op;
515
516	root	1.24	my $insn = { op => $op };
517
518			push @ops, $insn;
519
520			if (exists $extend{$name}) {
521			my $extend = $extend{$name};
522			$extend = $extend->($op) if ref $extend;
523			$insn->{extend} = $extend if defined $extend;
524			}
525
526			push @todo, $op->next;
527
528	root	1.11	if ($class eq "LOGOP") {
529	root	1.24	push @todo, $op->other;
530			$op_target{${$op->other}}++;
531	root	1.18
532			# regcomp/o patches ops at runtime, lets expect that
533	root	1.24	if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
534			$op_target{${$op->first}}++;
535			$op_regcomp{${$op->first}} = $op->next;
536			}
537	root	1.18
538	root	1.11	} elsif ($class eq "PMOP") {
539	root	1.24	if (${$op->pmreplstart}) {
540			unshift @todo, $op->pmreplstart;
541			$op_target{${$op->pmreplstart}}++;
542			}
543	root	1.18
544	root	1.11	} elsif ($class eq "LOOP") {
545	root	1.24	my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
546
547			push @op_loop, \@targ;
548			push @todo, @targ;
549
550			$op_target{$$_}++ for @targ;
551			} elsif ($class eq "COP") {
552			$insn->{bblock}++ if defined $op->label;
553	root	1.1	}
554			}
555			}
556
557	root	1.24	$_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
558
559	root	1.4	local $source = <<EOF;
560			OP *%%%FUNC%%% (pTHX)
561			{
562	root	1.24	register OP nextop = (OP )${$ops[0]->{op}}L;
563	root	1.4	EOF
564	root	1.2
565	root	1.8	while (@ops) {
566	root	1.24	$insn = shift @ops;
567
568			$op = $insn->{op};
569	root	1.8	$op_name = $op->name;
570	root	1.2
571	root	1.23	my $class = B::class $op;
572
573	root	1.24	$source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
574	root	1.8	$source .= "op_$$op: /* $op_name */\n";
575			#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
576	root	1.4	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
577
578	root	1.11	$source .= " PERL_ASYNC_CHECK ();\n"
579	root	1.20	unless exists $f_noasync{$op_name};
580	root	1.2
581	root	1.8	if (my $can = __PACKAGE__->can ("op_$op_name")) {
582	root	1.11	# handcrafted replacement
583	root	1.24
584			if ($insn->{extend} > 0) {
585			# coalesce EXTENDs
586			# TODO: properly take negative preceeding and following EXTENDs into account
587			for my $i (@ops) {
588			last if exists $i->{bblock};
589			last unless exists $i->{extend};
590			my $extend = delete $i->{extend};
591			$insn->{extend} += $extend if $extend > 0;
592			}
593
594			$source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
595			if $insn->{extend} > 0;
596			}
597
598	root	1.2	$can->($op);
599	root	1.11
600	root	1.20	} elsif (exists $f_unsafe{$op_name}) {
601	root	1.11	# unsafe, return to interpreter
602			assert "nextop == (OP *)$$op";
603	root	1.9	$source .= " return nextop;\n";
604	root	1.11
605	root	1.23	} elsif ("LOGOP" eq $class) {
606			# logical operation with optional branch
607	root	1.11	out_callop;
608			out_cond_jump $op->other;
609			out_jump_next;
610
611	root	1.23	} elsif ("PMOP" eq $class) {
612	root	1.11	# regex-thingy
613			out_callop;
614	root	1.23	out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
615	root	1.11	out_jump_next;
616
617	root	1.2	} else {
618	root	1.11	# normal operator, linear execution
619	root	1.8	out_linear;
620	root	1.2	}
621	root	1.1	}
622	root	1.2
623	root	1.11	$op_name = "func exit"; assert (0);
624
625			$source .= <<EOF;
626			op_0:
627			return 0;
628			}
629			EOF
630	root	1.4	#warn $source;
631	root	1.2
632	root	1.4	$source
633			}
634
635	root	1.19	my $uid = "aaaaaaa0";
636
637	root	1.4	sub source2ptr {
638	root	1.19	my (@source) = @_;
639	root	1.4
640	root	1.19	my $stem = "/tmp/Faster-$$-" . $uid++;
641	root	1.4
642	root	1.19	open FILE, ">:raw", "$stem.c";
643			print FILE <<EOF;
644	root	1.11	#define PERL_NO_GET_CONTEXT
645	root	1.24	#define PERL_CORE
646	root	1.11
647			#include <assert.h>
648
649			#include "EXTERN.h"
650			#include "perl.h"
651			#include "XSUB.h"
652
653			#define RUNOPS_TILL(op) \\
654	root	1.19	while (nextop != (op)) \\
655			{ \\
656			PERL_ASYNC_CHECK (); \\
657			PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
658			}
659	root	1.11
660			EOF
661	root	1.19	for (@source) {
662			my $func = $uid++;
663			$_ =~ s/%%%FUNC%%%/$func/g;
664			print FILE $_;
665			$_ = $func;
666	root	1.4	}
667
668	root	1.19	close FILE;
669			system "$COMPILE -o $stem$_o $stem.c";
670			#d#unlink "$stem.c";
671			system "$LINK -o $stem$_so $stem$_o $LIBS";
672			unlink "$stem$_o";
673
674	root	1.4	my $so = DynaLoader::dl_load_file "$stem$_so"
675			or die "$stem$_so: $!";
676
677	root	1.19	#unlink "$stem$_so";
678
679			map +(DynaLoader::dl_find_symbol $so, $_), @source
680	root	1.4	}
681
682	root	1.19	my %ignore;
683
684	root	1.4	sub entersub {
685			my ($cv) = @_;
686
687	root	1.19	my $pkg = $cv->STASH->NAME;
688
689			return if $ignore{$pkg};
690
691	root	1.21	warn "compiling ", $cv->STASH->NAME, "\n"
692			if $verbose;
693	root	1.11
694	root	1.4	eval {
695	root	1.19	my @cv;
696			my @cv_source;
697	root	1.4
698	root	1.19	# always compile the whole stash
699			my %stash = $cv->STASH->ARRAY;
700			while (my ($k, $v) = each %stash) {
701			$v->isa (B::GV::)
702			or next;
703
704			my $cv = $v->CV;
705
706			if ($cv->isa (B::CV::)
707			&& ${$cv->START}
708			&& $cv->START->name ne "null") {
709			push @cv, $cv;
710			push @cv_source, cv2c $cv;
711			}
712			}
713
714			my @ptr = source2ptr @cv_source;
715	root	1.4
716	root	1.19	for (0 .. $#cv) {
717			patch_cv $cv[$_], $ptr[$_];
718			}
719	root	1.4	};
720
721	root	1.19	if ($@) {
722			$ignore{$pkg}++;
723			warn $@;
724			}
725	root	1.1	}
726
727			hook_entersub;
728
729			1;
730
731			=back
732
733	root	1.21	=head1 ENVIRONMENT VARIABLES
734
735			The following environment variables influence the behaviour of Faster:
736
737			=over 4
738
739			=item FASTER_VERBOSE
740
741			Faster will output more informational messages when set to values higher
742			than C<0>. Currently, C<1> outputs which packages are being compiled.
743
744			=item FASTER_DEBUG
745
746			Add debugging code when set to values higher than C<0>. Currently, this
747			adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
748			execution order are compatible.
749
750			=item FASTER_CACHE
751
752			NOT YET IMPLEMENTED
753
754			Set a persistent cache directory that caches compiled code
755			fragments. Normally, code compiled by Faster will be deleted immediately,
756			and every restart will recompile everything. Setting this variable to a
757			directory makes Faster cache the generated files for re-use.
758
759			This directory will always grow in contents, so you might need to erase it
760			from time to time.
761
762			=back
763
764	root	1.11	=head1 BUGS/LIMITATIONS
765
766			Perl will check much less often for asynchronous signals in
767			Faster-compiled code. It tries to check on every function call, loop
768			iteration and every I/O operator, though.
769
770			The following things will disable Faster. If you manage to enable them at
771	root	1.19	runtime, bad things will happen. Enabling them at startup will be fine,
772			though.
773	root	1.11
774			enabled tainting
775			enabled debugging
776
777	root	1.19	Thread-enabled builds of perl will dramatically reduce Faster's
778			performance, but you don't care about speed if you enable threads anyway.
779	root	1.11
780	root	1.19	These constructs will force the use of the interpreter for the currently
781			executed function as soon as they are being encountered during execution.
782	root	1.11
783			goto
784			next, redo (but not well-behaved last's)
785			eval
786			require
787			any use of formats
788	root	1.19	.., ... (flipflop operators)
789	root	1.2
790	root	1.1	=head1 AUTHOR
791
792			Marc Lehmann <schmorp@schmorp.de>
793			http://home.schmorp.de/
794
795			=cut
796